希望能用VBA高效实现两表合并

jshamj

说明：

1       前两表关联字段唯一，但两表关键字段数据都不完全。

2       前两表数据都有2000行30列以上

要求：

1       将前两表合并成样表格式

2       如果单纯用循环、复制的方式效率太低。

3       希望能用VBA高效实现两表合并

4      最好能用数组或字典等方法实现

microyip

microyip

附上附件以供参考

jshamj

microyip 发表于 2020-6-14 12:25

很强大，但我能力有限，看不懂SQL.还有原工作簿中有三张表，表中有模拟数据。能用数组或字典等方式实现吗？谢谢

lwwy1981

jshamj 发表于 2020-6-14 13:33
很强大，但我能力有限，看不懂SQL.还有原工作簿中有三张表，表中有模拟数据。能用数组或字典等方式实 ...

可以用字典

Tree.IM

你的结果是使用powerquery做的吗？
我刚试了下用powerquery做，结果和你给的一样

lwwy1981

两个表都是2000行*30列的数据

lrh788

lwwy1981 发表于 2020-6-14 17:37
两个表都是2000行*30列的数据

lwwy1981 老师的代码写的太完美了。收藏留用！还请老师抽空到http://club.excelhome.net/thread-1542088-1-1.html帮我写下代码？

duquancai

meger               

shi353

速度很慢大概要半分鐘,但是還是可以獲得結果吧!
Sub sh1()
Sheet4.Activate
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
arr1 = Sheet2.[A1].CurrentRegion
arr2 = Sheet3.[A1].CurrentRegion
For i = 2 To UBound(arr1)
    d(arr1(i, 1)) = ""
Next
For i = 2 To UBound(arr2)
    d(arr2(i, 1)) = ""
Next
'--------------------------------------
Sheet4.Activate
Sheet4.Cells.ClearContents
tt1 = Application.Transpose(d.keys)
[A1] = "key"
[A2].Resize(UBound(tt1)) = tt1
'--------------------------------------
Set A = Range([A2], [A2].End(4))
For i = 1 To A.Cells.Count
    Set S = A.Cells(i)
    '----------------------------------
    For j = 2 To UBound(arr1)
        If S.Value = arr1(j, 1) Then
            S1 = Application.Index(arr1, j)
            S.Offset(, 1).Resize(, UBound(S1)) = S1
        End If
    Next
    '----------------------------------
    For j = 2 To UBound(arr2)
        If S.Value = arr2(j, 1) Then
            S1 = Application.Index(arr2, j)
            S.Offset(, UBound(arr1, 2) + 1).Resize(, UBound(S1)) = S1
        End If
    Next
    '----------------------------------
Next
'----------------------------------
ActiveSheet.Columns(2).EntireColumn.Delete
ActiveSheet.Columns(UBound(arr1, 2) + 1).EntireColumn.Delete
'----------------------------------
arr = Sheet4.[A1].CurrentRegion
For i = 1 To UBound(arr, 2) - 1
    With [A1]
        .Offset(, i) = "F" & i
    End With
Next
Application.ScreenUpdating = True
End Sub