VBA Excel如何将多个文件自动比较到一个主文件，然后复制/粘贴结果

=列表

=主列表

我想比较一下列表和主列表序列号。如果序列号中存在相似值，则序列号值将自动粘贴到第三列

Sub AutoUpdate()
Dim Dic As Object, key As Variant, oCell As Range, i&
Dim w1 As Worksheet, w2 As Worksheet

    Set Dic = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("Book1.xlsm").Sheets("Sheet1")
    Set w2 = Workbooks.Open("C:\UsersSurvey Testing\Book2.xlsx").Sheets("Sheet1")
    Set w3 = Workbooks.Open("C:\Users\Survey Testing\Book3.xlsx").Sheets("Sheet1")


    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each oCell In w2.Range("A2:A" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 0).Value
        End If

    Next
    i = w3.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each oCell In w3.Range("A2:A" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, 0).Value
        End If


    Next
    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row
    For Each oCell In w1.Range("A2:A" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 2).Value = Dic(key)
        End If


        Next
    Next

End Sub

---

我希望自动查找并设置文件夹中的所有工作簿并进行比较，而不是在代码中按1设置工作簿。因为可能有很多工作簿需要比较。

从概念上讲，这完全可以在没有VBA的情况下完成，使用Power Query，这是一个免费的Microsoft Excel 2010和2013加载项，并作为Get和Transform内置到Excel 2013中

打开文件夹中的所有文件，附加它们，删除重复文件并另存为主文件

---

添加新文件时，请刷新查询。

从概念上讲，这完全可以在不使用VBA的情况下使用Power query来完成。Power query是一个免费的Microsoft Excel 2010和2013加载项，作为Get和Transform内置到Excel 2013中

打开文件夹中的所有文件，附加它们，删除重复文件并另存为主文件

添加新文件后，刷新查询。

查看。根据该代码，您的代码将如下所示：

Sub Compare()
Dim Dic As Object
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fl As Object 'File
Dim Mask As String, i As Long
Dim Wbk As Workbook

Set fso = New FileSystemObject
Set fld = fso.GetFolder("C:\UsersSurvey Testing")

Set Dic = CreateObject("Scripting.Dictionary")

Mask = "*.xlsx"

For Each fl in fld.Files
    If fl.Name Like Mask Then
        Set Wbk = Workbooks.Open(fld & "\" & fl.Name).Sheets("Sheet1")
        i = Wbk.Cells.SpecialCells(xlCellTypeLastCell).Row
        For Each oCell In Wbk.Range("A2:A" & i)
            If Not Dic.exists(oCell.Value) Then
                Dic.Add oCell.Value, oCell.Offset(, 0).Value
            End If
        Next oCell
    End If
Next fl
End Sub

注意：我还没有测试这段代码。这只是为了让你知道该尝试什么。

看看。根据该代码，您的代码将如下所示：

Sub Compare()
Dim Dic As Object
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fl As Object 'File
Dim Mask As String, i As Long
Dim Wbk As Workbook

Set fso = New FileSystemObject
Set fld = fso.GetFolder("C:\UsersSurvey Testing")

Set Dic = CreateObject("Scripting.Dictionary")

Mask = "*.xlsx"

For Each fl in fld.Files
    If fl.Name Like Mask Then
        Set Wbk = Workbooks.Open(fld & "\" & fl.Name).Sheets("Sheet1")
        i = Wbk.Cells.SpecialCells(xlCellTypeLastCell).Row
        For Each oCell In Wbk.Range("A2:A" & i)
            If Not Dic.exists(oCell.Value) Then
                Dic.Add oCell.Value, oCell.Offset(, 0).Value
            End If
        Next oCell
    End If
Next fl
End Sub

---

注意：我还没有测试这段代码。这只是为了让您知道应该尝试什么。

在添加文件或从文件夹中删除文件的情况下，这不是很可靠。您不能只是刷新查询；您需要附加新文件并删除对旧文件的引用。错误。可以完全动态地打开文件夹中的所有文件，而不是按名称打开，而是只打开所有文件。Ken Puls有一个关于这个的博客哦，哇，你说得对。我忘记了“从文件夹导入”按钮。你说“打开文件夹中的所有文件”的方式在我的脑海中听起来很像手册。嘿，Teylyn，非常感谢你提供了伟大的替代解决方案。这是我学习新东西的好信息。不幸的是，我的老板更喜欢宏VBA，只要单击宏一次，一切都会自动运行。非常感谢您的快速回复！非常感谢！在添加文件或从文件夹中删除文件的情况下，这不是很可靠。您不能只是刷新查询；您需要附加新文件并删除对旧文件的引用。错误。可以完全动态地打开文件夹中的所有文件，而不是按名称打开，而是只打开所有文件。Ken Puls有一个关于这个的博客哦，哇，你说得对。我忘记了“从文件夹导入”按钮。你说“打开文件夹中的所有文件”的方式在我的脑海中听起来很像手册。嘿，Teylyn，非常感谢你提供了伟大的替代解决方案。这是我学习新东西的好信息。不幸的是，我的老板更喜欢宏VBA，只要单击宏一次，一切都会自动运行。非常感谢您的快速回复！非常感谢！谢谢你亚历克西斯的伟大解决方案。这正是我所需要的。显然，我的VBA Excel 2007没有读取Set fso=New FileSystemObject，但只有当代码是Set fso=CreateObject（“scripting.FileSystemObject”）时才能运行。我想知道为什么，无论如何，非常感谢你的帮助，非常感谢。谢谢你亚历克西斯的伟大解决方案。这正是我所需要的。显然，我的VBA Excel 2007没有读取Set fso=New FileSystemObject，但只有当代码是Set fso=CreateObject（“scripting.FileSystemObject”）时才能运行。我想知道为什么，无论如何，非常感谢你的帮助，非常感谢。