[已解决]需求帮助，有没有人能帮帮我~数据合并VBA

qqq123123

合并计算1.rar (32.84 KB, 下载次数: 39)

2011-10-13 14:24 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

兰色幻想

2011-10-15 17:07

Option Explicit
Sub 圆角矩形1_单击()
Dim 棋盘(1 To 1000, 1 To 6)
Dim 行数
Dim 姓名 As Object
Dim arr, arr1, x, k
Set 姓名 = CreateObject("scripting.dictionary")
arr = Sheets("数据库1").Range("b6:s" & Sheets("数据库1").Range("b65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If arr(x, 14) >= Range("c2") And arr(x, 14) <= Range("e2") Then
  If 姓名.Exists(arr(x, 12)) Then
      行数 = 姓名(arr(x, 12))
      棋盘(行数, 4) = 棋盘(行数, 4) + arr(x, 10)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  Else
      k = k + 1
      姓名(arr(x, 12)) = k
      行数 = k
      棋盘(行数, 1) = arr(x, 18)
      棋盘(行数, 2) = arr(x, 12)
      棋盘(行数, 3) = arr(x, 1)
      棋盘(行数, 4) = arr(x, 10)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  End If
  End If
Next x
arr1 = Sheets("数据库2").Range("b6:i" & Sheets("数据库2").Range("b65536").End(xlUp).Row)
  For x = 1 To UBound(arr1)
  If arr1(x, 2) >= Range("c2") And arr1(x, 2) <= Range("e2") Then
  If 姓名.Exists(arr1(x, 7)) Then
      行数 = 姓名(arr1(x, 7))
      棋盘(行数, 5) = 棋盘(行数, 5) + arr1(x, 4)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  Else
      k = k + 1
      姓名(arr1(x, 7)) = k
      行数 = k
      棋盘(行数, 1) = arr1(x, 1)
      棋盘(行数, 2) = arr1(x, 7)
      棋盘(行数, 3) = arr1(x, 3)
      棋盘(行数, 5) = arr1(x, 4)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  End If
End If
Next x
Sheets("合并结果").Range("B6").Resize(12, 6) = ""
Sheets("合并结果").Range("B6").Resize(k, 6) = 棋盘
End Sub

跳转到最佳答案楼层

兰色幻想

你到底是根据编号，还是姓名汇总的，你示例是按姓名的，但编号有两个

qqq123123

回复 兰色幻想 的帖子

兰老师~！

数据库2，B9单元格的编号H003应该是H001，是我写错了。

兰色幻想

Option Explicit
Sub 圆角矩形1_单击()
Dim 棋盘(1 To 1000, 1 To 6)
Dim 行数
Dim 姓名 As Object
Dim arr, arr1, x, k
Set 姓名 = CreateObject("scripting.dictionary")
arr = Sheets("数据库1").Range("b6:s" & Sheets("数据库1").Range("b65536").End(xlUp).Row)
For x = 1 To UBound(arr)
If arr(x, 14) >= Range("c2") And arr(x, 14) <= Range("e2") Then
  If 姓名.Exists(arr(x, 12)) Then
      行数 = 姓名(arr(x, 12))
      棋盘(行数, 4) = 棋盘(行数, 4) + arr(x, 10)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  Else
      k = k + 1
      姓名(arr(x, 12)) = k
      行数 = k
      棋盘(行数, 1) = arr(x, 18)
      棋盘(行数, 2) = arr(x, 12)
      棋盘(行数, 3) = arr(x, 1)
      棋盘(行数, 4) = arr(x, 10)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  End If
  End If
Next x
arr1 = Sheets("数据库2").Range("b6:i" & Sheets("数据库2").Range("b65536").End(xlUp).Row)
  For x = 1 To UBound(arr1)
  If arr1(x, 2) >= Range("c2") And arr1(x, 2) <= Range("e2") Then
  If 姓名.Exists(arr1(x, 7)) Then
      行数 = 姓名(arr1(x, 7))
      棋盘(行数, 5) = 棋盘(行数, 5) + arr1(x, 4)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  Else
      k = k + 1
      姓名(arr1(x, 7)) = k
      行数 = k
      棋盘(行数, 1) = arr1(x, 1)
      棋盘(行数, 2) = arr1(x, 7)
      棋盘(行数, 3) = arr1(x, 3)
      棋盘(行数, 5) = arr1(x, 4)
      棋盘(行数, 6) = 棋盘(行数, 4) - 棋盘(行数, 5)
  End If
End If
Next x
Sheets("合并结果").Range("B6").Resize(12, 6) = ""
Sheets("合并结果").Range("B6").Resize(k, 6) = 棋盘
End Sub

qqq123123

回复 兰色幻想 的帖子

兰老师，谢谢你的帮助！


请您再帮个忙，就是把您刚写的代码再修改下，能适用这个表格，小弟万分感激@~！


http://www.excelpx.com/thread-203672-1-1.html

蓝桥玄霜

1. Sub 圆角矩形1_单击()
   
2. Dim i&, Myr&, Myr2%, Arr, Arr2
   
3. Dim d, k, t, t2, x$, js, ks, m&, aa, r1
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Application.DisplayAlerts = False
   
7. Sheet17.Activate
   
8. [b6:g17].ClearContents
   
9. ks = [c2].Value: js = [e2].Value
   
10. Myr = Sheet1.[b65536].End(xlUp).Row
    
11. Arr = Sheet1.Range("a6:u" & Myr)
    
12. For i = 1 To UBound(Arr)
    
13.     If Arr(i, 15) >= ks And Arr(i, 15) <= js Then
    
14.         x = Arr(i, 19) & "," & Arr(i, 13) & "," & Arr(i, 2)
    
15.         d(x) = d(x) + Arr(i, 11)
    
16.     End If
    
17. Next
    
18. k = d.keys
    
19. t = d.items
    
20. [b6].Resize(d.Count, 1) = Application.Transpose(k)
    
21. [e6].Resize(d.Count, 1) = Application.Transpose(t): m = d.Count + 5
    
22. d.RemoveAll
    
23. Myr2 = Sheet2.[b65536].End(xlUp).Row
    
24. Arr2 = Sheet2.Range("a6:l" & Myr2)
    
25. For i = 1 To UBound(Arr2)
    
26.     If Arr2(i, 3) >= ks And Arr2(i, 3) <= js Then
    
27.         x = Arr2(i, 2) & "," & Arr2(i, 8) & "," & Arr2(i, 4)
    
28.         d(x) = d(x) + Arr2(i, 5)
    
29.     End If
    
30. Next
    
31. k2 = d.keys
    
32. t2 = d.items
    
33. For i = 0 To UBound(k2)
    
34.     Set r1 = [b:b].Find(k2(i))
    
35.     If Not r1 Is Nothing Then
    
36.         Cells(r1.Row, 6) = t2(i)
    
37.     Else
    
38.         m = m + 1
    
39.         Cells(m, 2) = k2(i)
    
40.         Cells(m, 6) = t2(i)
    
41.     End If
    
42. Next
    
43. Cells(6, 2).Resize(11, 1).TextToColumns Destination:=Cells(6, 2), Comma:=True
    
44. Myr = [c65536].End(xlUp).Row
    
45. For i = 6 To Myr
    
46.     Cells(i, 7) = Cells(i, 5) - Cells(i, 6)
    
47. Next
    
48. Cells(Myr + 1, 4) = "合计"
    
49. Cells(Myr + 1, 5).Resize(1, 3).Formula = "=sum(r6c:r[-1]c)"
    
50. Set d = Nothing
    
51. Application.DisplayAlerts = True
    
52. Application.ScreenUpdating = True
    
53. End Sub
    

复制代码

蓝桥玄霜

请见附件。

qqq123123

回复 蓝桥玄霜 的帖子

蓝桥玄霜老师谢谢您！
能否帮忙再帮个忙~！
将（数据库1、数据库2）每天的金额用这种方式显示。
请看下面的帖子~谢谢！


http://www.excelpx.com/thread-203672-1-1.html