如何将薪酬变动项表中的变动项按标题栏导入明细库中？

海王星123

老师、大神们好：
如何将表2的变动项导入对应表1中标题相同的列中去呢？请教请教！！！万分感谢！！！

3190496160

Sub 匹配数据()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim ar As Variant, bi As Variant
ar = Sheets("费用明细").[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        d(Trim(ar(i, 2))) = i
    End If
Next i
For j = 3 To UBound(ar, 2)
    If Trim(ar(1, j)) <> "" Then
        d(Trim(ar(1, j))) = j
    End If
Next j
br = Sheets("变动").[a1].CurrentRegion
For i = 2 To UBound(br)
    If Trim(br(i, 2)) <> "" Then
        n = d(Trim(br(i, 2)))
        If n <> "" Then
            For j = 3 To UBound(br, 2)
                If Trim(br(i, j)) <> "" Then
                    m = d(Trim(br(1, j)))
                    If m <> "" Then
                        ar(n, m) = br(i, j)
                    End If
                End If
            Next j
        End If
    End If
Next i
Sheets("费用明细").[a1].CurrentRegion = ar
MsgBox "ok!"
End Sub

3190496160

结果未经核对，代码供参考

海王星123

3190496160 发表于 2020-10-18 10:49
结果未经核对，代码供参考

谢谢！！非常感谢，请问如何将“导入表”的需导入的模板设定为动态的？如根据导入表“A1”单元格的下拉菜单。这样我有20张表就不需依次改名导入了？谢谢！！！

3190496160

不明白你的意思

海王星123

3190496160 发表于 2020-10-18 22:45
不明白你的意思

Sub 导入数据()
    Set d = CreateObject("scripting.dictionary")
    arr = [a2].CurrentRegion
    For i = 2 To UBound(arr)
        For j = 2 To UBound(arr, 2)
                s = arr(i, 2) & arr(1, j)
                d(s) = arr(i, j)
        Next
    Next
    With Sheets("费用明细")
        brr = .[a1].CurrentRegion
        For i = 2 To UBound(brr)
            For j = 2 To UBound(brr, 2)
                s = .Cells(i, 3) & .Cells(1, j)
                If d.exists(s) Then .Cells(i, j) = d(s)
            Next
        Next
    End With
End Sub
是这样的，我需导入的要20张表，每次在“变动”表中的下拉菜单中选择1-20表，在代码中能否根据下拉菜单的表名分别将对应的列导入对应的表！如果把红色的那句改成：根据当前表（2表）的A1单元格返回的表名选择对应表名的表来导入。谢谢！！

3190496160

海王星123 发表于 2020-10-19 08:02
Sub 导入数据()
    Set d = CreateObject("scripting.dictionary")
    arr = [a2].CurrentRegion

Sub 匹配数据()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim ar As Variant, bi As Variant
ar = Sheets("费用明细").[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 2)) <> "" Then
        d(Trim(ar(i, 2))) = i
    End If
Next i
For j = 3 To UBound(ar, 2)
    If Trim(ar(1, j)) <> "" Then
        d(Trim(ar(1, j))) = j
    End If
Next j
mc = Sheets("费用明细").[a1]
br = Sheets(mc).[a1].CurrentRegion
For i = 2 To UBound(br)
    If Trim(br(i, 2)) <> "" Then
        n = d(Trim(br(i, 2)))
        If n <> "" Then
            For j = 3 To UBound(br, 2)
                If Trim(br(i, j)) <> "" Then
                    m = d(Trim(br(1, j)))
                    If m <> "" Then
                        ar(n, m) = br(i, j)
                    End If
                End If
            Next j
        End If
    End If
Next i
Sheets("费用明细").[a1].CurrentRegion = ar
MsgBox "ok!"
End Sub

海王星123

3190496160 发表于 2020-10-19 08:30
Sub 匹配数据()
Dim d As Object
Set d = CreateObject("scripting.dictionary")

附件您帮忙看一下！！谢谢了！

海王星123

附件，麻烦您查收！！！！