Excel VBA 读取其他的Excel文件内的内容

ykcbf1100

参与一下。。。

任雨听风

ykcbf1100 发表于 2024-9-29 16:35
参与一下。。。

谢谢大佬，辛苦

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, strFileName$, strPath$, dic As Object, strKey$
   
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.xlsx")
    Do Until strFileName = ""
        With GetObject(strPath & strFileName)
        ar = .Worksheets(1).[A1].CurrentRegion.Value
        For j = 2 To UBound(ar, 2)
            For i = 2 To UBound(ar)
                strKey = ar(i, 1) & "|" & ar(1, j)
                dic(strKey) = ar(i, j)
            Next i
        Next j
            .Close False
        End With
        strFileName = Dir
    Loop
   
    ar = [A1].CurrentRegion.Value
    For j = 4 To UBound(ar, 2)
        For i = 2 To UBound(ar)
            strKey = ar(i, 1) & "|" & ar(1, j)
             ar(i, j) = dic(strKey)
        Next i
    Next j
   
    [A1].CurrentRegion.Value = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

任雨听风

ykcbf1100 发表于 2024-9-29 16:35
参与一下。。。

我试了一下，不能把数据提取到对应列呢，是我哪里错了吗

任雨听风

gwjkkkkk 发表于 2024-9-29 17:35
Option Explicit
Sub test()
    Dim ar, i&, j&, strFileName$, strPath$, dic As Object, strKey$

为什么我运行的时候不行呢，除了前三列字体变化了，后面四列没有数据填充

ykcbf1100

任雨听风 发表于 2024-9-30 09:28
我试了一下，不能把数据提取到对应列呢，是我哪里错了吗

你用我的附件先试一下，行不行？
我这里测试是没问题的。

任雨听风

ykcbf1100 发表于 2024-9-30 09:52
你用我的附件先试一下，行不行？
我这里测试是没问题的。

麻烦您把附件发给我试一下

ykcbf1100

任雨听风 发表于 2024-9-30 10:00
麻烦您把附件发给我试一下

我的附件在10楼，你去看看。

任雨听风

ykcbf1100 发表于 2024-9-30 10:02
我的附件在10楼，你去看看。

果然可以，谢谢您