VBA跨工作簿匹配多列数据到指定位置

小旋旋 · 发表于 2024-2-28 08:45

小白求助！
需要将1.xlsm中的数据根据唯一编码匹配到报表.xlsm数据中，根据表头一一对应
站内搜到了类似的问题，大概看懂一点后根据他们的代码进行了修改，可是总也不成功，麻烦大佬们帮忙看看问题出在哪里？或者帮忙修改一下，谢谢

数据.zip (52.03 KB, 下载次数: 8)

Sub AwTest()
Dim i%, j%, kStr$, ws As Worksheet, wb As Workbook, arr, d As Object
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set wb = Workbooks.Open(ThisWorkbook.Path & "\1.xlsm")
Set ws = wb.Sheets("数据")
arr = ws.[a1].CurrentRegion
For i = 2 To UBound(arr)
      d(arr(i, 1)) = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6) & "|" & arr(i, 7) & "|" & arr(i, 8) & "|" & arr(i, 9) & "|" & arr(i, 10) & "|" & arr(i, 11) & "|" & arr(i, 12)
Next
wb.Close False
[a1].CurrentRegion.Offset(1, 11) = ""
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
      If d.exists(arr(i, 11)) Then
         kStr = d(arr(i, 11))
         For j = -3 To 9
            arr(i, j + 11) = Split(kStr, "|")(j)
         Next
      End If
Next
[a1].CurrentRegion = arr
Application.ScreenUpdating = True
End Sub

ykcbf1100 · 发表于 2024-2-28 11:49

本帖最后由 ykcbf1100 于 2024-2-28 14:00 编辑

代码在数据.xlsm文件中

ykcbf1100 · 发表于 2024-2-28 11:50

参与一下。。。

Sub ykcbf() '//2024.2.28
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set sh = ThisWorkbook.Sheets("Sheet1")
p = ThisWorkbook.Path
f = p & "\1.xlsm"
Set wb = Workbooks.Open(f, 0)
With wb.Sheets("数据")
arr = .UsedRange
wb.Close False
End With
For i = 2 To UBound(arr)
For j = 2 To UBound(arr, 2)
s = arr(i, 1) & "|" & arr(1, j)
d(s) = arr(i, j)
Next
Next
With sh
arr = .UsedRange
For i = 2 To UBound(arr)
For j = 1 To 10
s = arr(i, 11) & "|" & arr(1, j)
If d.exists(s) Then
arr(i, j) = d(s)
End If
Next
For j = 12 To UBound(arr, 2)
s = arr(i, 11) & "|" & arr(1, j)
If d.exists(s) Then
arr(i, j) = d(s)
End If
Next
Next
.UsedRange = arr
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

fzxba · 发表于 2024-2-28 13:31

Sub test0()
Dim ar, br() As String, cr() As Long, dict As Object
Dim i As Long, j As Long, k As Long, p As Long, s As String
Application.ScreenUpdating = False
Set dict = CreateObject("Scripting.Dictionary")
ar = Range("I1:R" & Cells(Rows.Count, "K").End(xlUp).Row)
ReDim br(1 To UBound(ar) - 1, 1 To UBound(ar, 2))
For j = 1 To UBound(ar, 2)
s = Trim(ar(1, j))
If Len(s) Then dict.Add s, j
Next
For i = 2 To UBound(ar)
s = Trim(ar(i, 3))
If Len(s) Then dict.Add s, i - 1
br(i - 1, 3) = s
Next
With Workbooks.Open(ThisWorkbook.Path & "\1.xlsm", 0)
ar = .Worksheets("数据").Range("A1").CurrentRegion
.Close False
End With
For j = 1 To UBound(ar, 2)
s = Trim(ar(1, j))
If dict.Exists(s) Then
k = k + 1
ReDim Preserve cr(1 To 2, 1 To k)
cr(1, k) = j
cr(2, k) = dict(s)
End If
Next
For i = 2 To UBound(ar)
s = Trim(ar(i, 1))
If dict.Exists(s) Then
p = dict(s)
For j = 1 To k
br(p, cr(2, j)) = ar(i, cr(1, j))
Next
End If
Next
Range("I2").Resize(UBound(br), UBound(br, 2)) = br
Set dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

fzxba · 发表于 2024-2-28 13:58

报表.zip (52.6 KB, 下载次数: 11)

		自动登录	找回密码
密码			免费注册

[求助] VBA跨工作簿匹配多列数据到指定位置

评分

评分