[已解决]怎么样合并两表把 货号对应起来？

dehaijun2

问题(1).rar (22.21 KB, 下载次数: 6)

2016-12-21 19:06 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-12-22 11:27

1. Sub 合并()
   
2.     arr = Sheets(1).[a1].CurrentRegion
   
3.     brr = Sheets(2).[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(brr)
   
6.         d(brr(i, 2)) = d(brr(i, 2)) & "," & i
   
7.     Next
   
8.    
   
9.     With ActiveSheet
   
10.         .Cells.Clear
    
11.         For i = 2 To UBound(arr)
    
12.             x = arr(i, 2)
    
13.             If d.exists(x) Then
    
14.                 xrr = Split(d(x), ",")
    
15.                 ReDim crr(1 To UBound(xrr) + 1, 1 To 7)
    
16.                 crr(1, 1) = arr(i, 1)
    
17.                 crr(1, 2) = x
    
18.                 crr(1, 3) = arr(i, 3)
    
19.                 crr(UBound(crr), 4) = x & "汇总"
    
20.                 For ii = 1 To UBound(xrr)
    
21.                     crr(ii, 4) = x
    
22.                     crr(ii, 5) = brr(xrr(ii), 1)
    
23.                     crr(ii, 6) = brr(xrr(ii), 3)
    
24.                     crr(UBound(crr), 6) = crr(UBound(crr), 6) + brr(xrr(ii), 3)
    
25.                 Next
    
26.                 crr(UBound(crr), 7) = crr(UBound(crr), 6) - crr(1, 3)
    
27.                 r = .[d65536].End(3).Row + 2
    
28.                 .Cells(r, 1).Resize(1, 7) = Array("物料长代码", "物料短代码", "系统数量", "货号", "架位", "盘点数量", "盈亏")
    
29.                 .Cells(r + 1, 1).Resize(ii, 7) = crr
    
30.                 .Cells(r + 1, 1).Resize(ii).Merge
    
31.                 .Cells(r + 1, 2).Resize(ii).Merge
    
32.                 .Cells(r + 1, 3).Resize(ii).Merge
    
33.                 .Cells(r, 1).Resize(ii + 1, 7).Borders.LineStyle = 1
    
34.             End If
    
35.         Next
    
36.         .Rows("1:2").Delete
    
37.         .Columns.AutoFit
    
38.     End With
    
39.             
    
40. End Sub
    

复制代码

跳转到最佳答案楼层

momo8238

可以直接用vlookup 函数

momo8238

直接用VLOOKUP 函数

grf1973

1. Sub 合并()
   
2.     arr = Sheets(1).[a1].CurrentRegion
   
3.     brr = Sheets(2).[a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(brr)
   
6.         d(brr(i, 2)) = d(brr(i, 2)) & "," & i
   
7.     Next
   
8.    
   
9.     With ActiveSheet
   
10.         .Cells.Clear
    
11.         For i = 2 To UBound(arr)
    
12.             x = arr(i, 2)
    
13.             If d.exists(x) Then
    
14.                 xrr = Split(d(x), ",")
    
15.                 ReDim crr(1 To UBound(xrr) + 1, 1 To 7)
    
16.                 crr(1, 1) = arr(i, 1)
    
17.                 crr(1, 2) = x
    
18.                 crr(1, 3) = arr(i, 3)
    
19.                 crr(UBound(crr), 4) = x & "汇总"
    
20.                 For ii = 1 To UBound(xrr)
    
21.                     crr(ii, 4) = x
    
22.                     crr(ii, 5) = brr(xrr(ii), 1)
    
23.                     crr(ii, 6) = brr(xrr(ii), 3)
    
24.                     crr(UBound(crr), 6) = crr(UBound(crr), 6) + brr(xrr(ii), 3)
    
25.                 Next
    
26.                 crr(UBound(crr), 7) = crr(UBound(crr), 6) - crr(1, 3)
    
27.                 r = .[d65536].End(3).Row + 2
    
28.                 .Cells(r, 1).Resize(1, 7) = Array("物料长代码", "物料短代码", "系统数量", "货号", "架位", "盘点数量", "盈亏")
    
29.                 .Cells(r + 1, 1).Resize(ii, 7) = crr
    
30.                 .Cells(r + 1, 1).Resize(ii).Merge
    
31.                 .Cells(r + 1, 2).Resize(ii).Merge
    
32.                 .Cells(r + 1, 3).Resize(ii).Merge
    
33.                 .Cells(r, 1).Resize(ii + 1, 7).Borders.LineStyle = 1
    
34.             End If
    
35.         Next
    
36.         .Rows("1:2").Delete
    
37.         .Columns.AutoFit
    
38.     End With
    
39.             
    
40. End Sub
    

复制代码

dehaijun2

感谢grf1973 看来这个世上没有什么做不到的，真是牛

雄鹰2013

Sub 对比合并()
Dim arr, brr, crr(1 To 1000, 1 To 7)
Application.ScreenUpdating = False
t = Timer
arr = Sheets("系统").Range("a1").CurrentRegion
brr = Sheets("盘点数量").Range("a1").CurrentRegion
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Columns("I:O").Clear
For i = 2 To UBound(arr)
     d(arr(i, 2)) = i '物料代码与行号一一对应
Next i
For i = 2 To UBound(brr)
     d2(brr(i, 2)) = d2(brr(i, 2)) & "," & i '将代码与行号对应
Next i
For Each k In d.keys
     If d2.exists(k) Then
        x = 1
        h = d(k)
        For j = 1 To 3
            crr(x, j) = arr(h, j)
        Next j
        s1 = arr(h, 3)
        ar = Split(d2(k), ",")
        For i = 1 To UBound(ar)
            h = ar(i)
            crr(x, 4) = brr(h, 2)
            crr(x, 5) = brr(h, 1)
            crr(x, 6) = brr(h, 3)
            s2 = s2 + crr(x, 6)
            x = x + 1
        Next i
        crr(x, 4) = k & "汇总"
        crr(x, 6) = s2
        crr(x, 7) = s2 - s1
     End If
     r = Cells(Rows.Count, 12).End(xlUp).Row
     r = IIf(r = 1, 1, r + 2)
     Cells(r, 9).Resize(1, 7) = Array("物料长代码", "物料短代码", "系统数量", "货号", "架位", "盘点数量", "盈亏")
     Cells(r + 1, 9).Resize(x, 7) = crr
     Cells(r + 1, 9).Resize(x).Merge
     Cells(r + 1, 10).Resize(x).Merge
     Cells(r + 1, 11).Resize(x).Merge
     Range(Cells(r, 9), Cells(r + x, 15)).Borders.LineStyle = 1
     Columns("I:O").AutoFit
     s2 = 0
Next k
Application.ScreenUpdating = True
MsgBox Format(Timer - t, "0.00秒")
End Sub