提取两表中两列都相同的数据到表三

ww0000

Book1.zip (5.45 KB, 下载次数: 12)

2020-2-1 21:57 上传

点击文件名下载附件

提取两表中两列都相同的数据到表三

zyr2046

字典+数组比较擅长解决这个问题

excel海

字典真是专搞这种事的

1. Sub test()
   
2.     Dim arr, brr, i
   
3.     Dim dic
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("表一").UsedRange
   
6.     brr = Sheets("表二").UsedRange
   
7.     For i = 1 To UBound(arr)
   
8.         dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
   
9.     Next
   
10.      For i = 1 To UBound(brr)
    
11.         dic(brr(i, 1)) = dic(brr(i, 1)) + brr(i, 2)
    
12.     Next
    
13.     With Sheets("表三")
    
14.         .Cells.ClearContents
    
15.         .Cells(3, 2).Resize(dic.Count) = Application.Transpose(dic.keys)
    
16.         .Cells(3, 3).Resize(dic.Count) = Application.Transpose(dic.items)
    
17.     End With
    
18. End Sub
    

复制代码

shenjianrong163

excel海 发表于 2020-2-1 23:34
字典真是专搞这种事的

请问3楼是不是弄反了，楼主是想取重，你这个是去重汇总吧?

shenjianrong163

Sub test()
    Dim i%, j%, arr, brr, crr
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    With Worksheets("表一")
        arr = .Range("b2:c10")
    End With
    With Worksheets("表二")
        brr = Sheet2.Range("b3:c9")
    End With
    For i = 1 To UBound(arr)
        d1(arr(i, 1)) = arr(i, 2)
    Next
    For j = 1 To UBound(brr)
        If d1.exists(brr(j, 1)) And d1(brr(j, 1)) = brr(j, 2) Then
            d2(brr(j, 1)) = brr(j, 2)
        End If
    Next
    crr = Application.Transpose(Array(d2.Keys, d2.Items))
    With Worksheets("表三")
        .Range("b3:c" & .Cells(.Rows.Count, 3).End(xlUp).Row).ClearContents
        .Range("b3").Resize(d2.Count, 2) = crr
    End With
End Sub

excel海

shenjianrong163 发表于 2020-2-2 09:02
请问3楼是不是弄反了，楼主是想取重，你这个是去重汇总吧?

确实是我搞错了,谢谢提醒!!
直接用数组也可以完成

1. Sub test1()
   
2.     Dim arr, brr, i, crr(), j, k
   
3.     Dim dic
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("表一").UsedRange
   
6.     brr = Sheets("表二").UsedRange
   
7.     For i = 1 To UBound(arr)
   
8.         For j = 1 To UBound(brr)
   
9.             If arr(i, 1) = brr(j, 1) And arr(i, 2) = brr(j, 2) Then
   
10.                 k = k + 1
    
11.                 ReDim Preserve crr(1 To 2, 1 To k)
    
12.                 crr(1, k) = arr(i, 1)
    
13.                 crr(2, k) = arr(i, 2)
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     With Sheets("表三")
    
18.         .Cells.ClearContents
    
19.         crr = Application.Transpose(crr)
    
20.         .Cells(3, 2).Resize(UBound(crr, 1), UBound(crr, 2)) = crr
    
21.     End With
    
22. End Sub

复制代码

ww0000

zyr2046 发表于 2020-2-1 22:55
字典+数组比较擅长解决这个问题

谢谢，就这个效果！

ww0000

谢谢大家，就这个效果！