求助用VBA合并工作表数据

Justin-2016

求助用VBA合并工作表数据.zip (10.48 KB, 下载次数: 8)

2018-9-12 11:29 上传

点击文件名下载附件

结果如以下黑色字体部分摸拟效果

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet2")
   
7.     r = .Cells(.Rows.Count, 3).End(xlUp).Row
   
8.     arr = .Range("b3:d" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Len(arr(i, 1)) <> 0 Then
    
11.         xm = arr(i, 1)
    
12.       End If
    
13.       If Len(arr(i, 3)) <> 0 Then
    
14.         If Not d.exists(xm) Then
    
15.           m = 1
    
16.           ReDim brr(1 To 2, 1 To m)
    
17.         Else
    
18.           brr = d(xm)
    
19.           m = UBound(brr, 2) + 1
    
20.           ReDim Preserve brr(1 To 2, 1 To m)
    
21.         End If
    
22.         brr(1, m) = arr(i, 2)
    
23.         brr(2, m) = arr(i, 3)
    
24.         d(xm) = brr
    
25.       End If
    
26.     Next
    
27.   End With
    
28.   With Worksheets("sheet3")
    
29.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
30.     arr = .Range("b3:f" & r)
    
31.   End With
    
32.   With Worksheets("sheet4")
    
33.     .Range("b3:i" & .Rows.Count).Clear
    
34.     m = 3
    
35.     For i = 1 To UBound(arr)
    
36.       m0 = m
    
37.       For Each aa In d.keys
    
38.         m1 = m
    
39.         brr = d(aa)
    
40.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
41.         For x = 1 To UBound(brr)
    
42.           For y = 1 To UBound(brr, 2)
    
43.             crr(y, x) = brr(x, y)
    
44.           Next
    
45.         Next
    
46.         For x = 1 To UBound(crr)
    
47.           crr(x, 2) = arr(i, 5) - crr(x, 2)
    
48.         Next
    
49.         With .Cells(m, 7)
    
50.           .Value = aa
    
51.           .Resize(UBound(crr), 1).Merge
    
52.         End With
    
53.         .Cells(m, 8).Resize(UBound(crr), UBound(crr, 2)) = crr
    
54.         m = m + UBound(crr)
    
55.       Next
    
56.       .Cells(m0, 2).Resize(1, 5) = Application.Index(arr, i, 0)
    
57.       For j = 2 To 6
    
58.         .Cells(m0, j).Resize(m - m0, 1).Merge
    
59.       Next
    
60.     Next
    
61.     .Range("b2:i" & m - 1).Borders.LineStyle = xlContinuous
    
62.   End With
    
63. End Sub
    

复制代码

chxw68

详见附件。