Excel 从多个选定文件复制一系列数据

我试图在一系列单元格上复制多个文件中的数据

我做了一些事情，但我必须将文件保存在特定路径中，或者有时手动复制一个工作簿中的单元格区域

我想选择工作簿并保存到现有工作簿上，因为页眉可以有一些引用，有时文件会保护VBA项目

“我的代码”从第一个工作表中复制一行，从第二个工作表中复制指定文件夹中打开的文件中的一系列单元格，然后将这些单元格保存到代码所在的文件中

Sub LoopThroughDirectory()
    On Error Resume Next
    Dim MyFile As String
    Dim erow
    Dim erowc
    Dim Filepath As String
    Filepath = "C:\Users\noStress\Desktop\Workbook test\Destinatia mea\"
    MyFile = Dir(Filepath)

    Dim Matrice() As Variant
    Dim Dim1, Dim2 As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Do While Len(MyFile) > 0
        If MyFile = "Transport_data.xlsm" Then
            Exit Sub
        End If

        Workbooks.Open (Filepath & MyFile)
        Worksheets(1).Activate
        Range("A2:M2").Copy
        Worksheets(2).Activate
        Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1
        Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1

        ReDim Matrice(0 To Dim1, 0 To Dim2)
        For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1)
            For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2)

                Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value

            Next Dim2
        Next Dim1
        ActiveWorkbook.Close

        Worksheets(2).Activate
        erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice

        Worksheets(1).Activate
        erow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets(1).Range(Cells(erow, 1), Cells(erow, 14))

        MyFile = Dir
    Loop
End Sub

---

我希望我做对了

您想：

• 从特定文件夹中动态选择文件
• 将工作表1和工作表2中所选文件中的单元格复制到当前工作簿中
• 是否保存当前工作簿？（我没有完全理解你在这里的意思，所以我省略了这一部分）

我的看法是：

创建一个带有列表框（lstFile，2列）和命令按钮（cmdCopy）的用户表单（ufCopy）

在工作表上创建命令按钮以启动它

在Extras->References中选中“Microsoft脚本运行时”，以避免创建对象

将此代码复制到userforms源代码中

代码：

    Private Sub UserForm_Initialize()

        Call GetFiles("C:\example\example") 'Enter your folder path here

    End Sub

    Private Sub GetFiles(strFile As String)

        '
        'Populates Listbox with all Excel files in the chosen folder and subfolders
        '

        Dim fso As Scripting.FileSystemObject
        Dim fsoFolder As Scripting.Folder
        Dim fsoSubfolder As Scripting.Folder
        Dim fsoFile As Scripting.File

        Set fso = New Scripting.FileSystemObject
        Set fsoFolder = fso.GetFolder(strFile)

        For Each fsoFile In fsoFolder.Files

            If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then
                With Me.lstFiles
                    .AddItem
                    .List(.ListCount - 1, 0) = fsoFile.Name
                    .List(.ListCount - 1, 1) = fsoFile.Path
                End With
            End If

        Next fsoFile

        For Each fsoSubfolder In fsoFolder.SubFolders

            Call GetFiles(fsoSubfolder.Path)

        Next fsoSubfolder

    End Sub

    Private Sub cmdCopy_Click()

        Dim Msg As String
        Dim iCounter As Integer
        Dim wbCur As Workbook

        Application.ScreenUpdating = False   

        For iCounter = 0 To Me.lstFiles.ListCount - 1

             If Me.lstFiles.Selected(iCounter) Then

                Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1))
                '
                'Copy from first sheet
                '
                wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                '
                'Copy from second sheet
                '
                With wbCur.Worksheets(2)
                    .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With

                wbCur.Close savechanges:=False

              End If
        Next iCounter

        Application.ScreenUpdating = True
    End Sub

这是：

• 在多选列表框中显示所选文件夹和子文件夹的所有Excel文件
• 循环浏览所有选定工作簿并将单元格复制到此工作簿

我不知道这个数组的用途，所以我把它删除了。您可以根据需要自由调整代码以进行复制

要启动userform，请将其复制到包含命令按钮的工作表的代码中：

Private Sub CommandButton1_Click()

    ufCopy.Show

End Sub

编辑： 要动态选择文件夹路径，请使用以下命令：

Private Sub UserForm_Initialize()

Dim strFolder
Dim fdFolder As FileDialog

' Open the file dialog
Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.AllowMultiSelect = False
fdFolder.Show

strFolder = fdFolder.SelectedItems(1)

Call GetFiles(strFolder)

End Sub

---

如果您想从不同的路径获取文件，只需将上述代码添加到userform上的命令按钮，而不是初始化。这样你就可以点击它并添加多个目录。

我希望我做对了

您想：

• 从特定文件夹中动态选择文件
• 将工作表1和工作表2中所选文件中的单元格复制到当前工作簿中
• 是否保存当前工作簿？（我没有完全理解你在这里的意思，所以我省略了这一部分）

我的看法是：

创建一个带有列表框（lstFile，2列）和命令按钮（cmdCopy）的用户表单（ufCopy）

在工作表上创建命令按钮以启动它

在Extras->References中选中“Microsoft脚本运行时”，以避免创建对象

将此代码复制到userforms源代码中

代码：

    Private Sub UserForm_Initialize()

        Call GetFiles("C:\example\example") 'Enter your folder path here

    End Sub

    Private Sub GetFiles(strFile As String)

        '
        'Populates Listbox with all Excel files in the chosen folder and subfolders
        '

        Dim fso As Scripting.FileSystemObject
        Dim fsoFolder As Scripting.Folder
        Dim fsoSubfolder As Scripting.Folder
        Dim fsoFile As Scripting.File

        Set fso = New Scripting.FileSystemObject
        Set fsoFolder = fso.GetFolder(strFile)

        For Each fsoFile In fsoFolder.Files

            If Left(fso.GetExtensionName(fsoFile.Path), 2) = "xl" Then
                With Me.lstFiles
                    .AddItem
                    .List(.ListCount - 1, 0) = fsoFile.Name
                    .List(.ListCount - 1, 1) = fsoFile.Path
                End With
            End If

        Next fsoFile

        For Each fsoSubfolder In fsoFolder.SubFolders

            Call GetFiles(fsoSubfolder.Path)

        Next fsoSubfolder

    End Sub

    Private Sub cmdCopy_Click()

        Dim Msg As String
        Dim iCounter As Integer
        Dim wbCur As Workbook

        Application.ScreenUpdating = False   

        For iCounter = 0 To Me.lstFiles.ListCount - 1

             If Me.lstFiles.Selected(iCounter) Then

                Set wbCur = Workbooks.Open(Me.lstFiles.List(iCounter, 0) & Me.lstFiles.List(iCounter, 1))
                '
                'Copy from first sheet
                '
                wbCur.Worksheets(1).Range("A2:M2").Copy Destination:=ThisWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                '
                'Copy from second sheet
                '
                With wbCur.Worksheets(2)
                    .Range("A1", .Range("A2").End(xlDown).End(xlToRight)).Copy Destination:=ThisWorkbook.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                End With

                wbCur.Close savechanges:=False

              End If
        Next iCounter

        Application.ScreenUpdating = True
    End Sub

这是：

• 在多选列表框中显示所选文件夹和子文件夹的所有Excel文件
• 循环浏览所有选定工作簿并将单元格复制到此工作簿

我不知道这个数组的用途，所以我把它删除了。您可以根据需要自由调整代码以进行复制

要启动userform，请将其复制到包含命令按钮的工作表的代码中：

Private Sub CommandButton1_Click()

    ufCopy.Show

End Sub

编辑： 要动态选择文件夹路径，请使用以下命令：

Private Sub UserForm_Initialize()

Dim strFolder
Dim fdFolder As FileDialog

' Open the file dialog
Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.AllowMultiSelect = False
fdFolder.Show

strFolder = fdFolder.SelectedItems(1)

Call GetFiles(strFolder)

End Sub

---

如果您想从不同的路径获取文件，只需将上述代码添加到userform上的命令按钮，而不是初始化。这样，您可以单击它并添加多个目录。

对代码的注释

Application.DisplayAlerts=False

表示用户将不会看到任何警报。在我看来，这是危险的。我用这句话是为了：

Application.DisplayAlerts = False
Delete worksheet
Application.DisplayAlerts = True

也就是说，我关闭单个语句的警报。如果合适的话，我已经和用户核实过，删除工作表是可以的

---

我假设Transport_data.xlsm是包含宏的工作簿。通常，Dir会按照创建的顺序返回文件，因此不会处理在Transport_data.xlsm之后创建的任何文件。你想要的是：

If MyFile <> "Transport_data.xlsm" Then
  Process file
End If

---

工作表（N）

是选项卡上的第N个工作表。如果用户更改了工作表的顺序，工作表编号也会更改，您可能无法获得预期的工作表

始终按名称标识工作表：

工作表（“xxxxx”）

工作表（N）激活

速度慢，应避免使用

在以下步骤中，您将激活

工作表（2）

，然后完全限定要在工作表中使用的工作表 以下声明：

Worksheets(2).Activate
erowc = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

您不需要

激活

---

你用

`ThisWorkbook.Worksheets(2).Range(Cells(erowc, 1), Cells(Dim1 + erowc - 1, Dim2)).Value = Matrice`

下载到目标范围，但逐个单元格从源范围加载

Matrice

。您可以用同样的方法加载

矩阵

Dim Matrice As Variant

Matrice = SourceRange.Value          ' This will size Matrice as required
DestinationRange.Value = Matrice

您的要求

您希望从多个工作簿中提取数据，而不是全部存储在同一文件夹中。您假设（希望）您需要的工作表是第一个工作表。宏会复制整个工作表，但文本意味着您希望更具选择性。由于您希望自动化该过程，我假设这是一个每隔一段时间重复的过程

我可能是急于下结论，但这听起来像是我的一位客户的要求。他们从他们的来源收到了多个工作簿，但他们只需要为其管理摘要选择信息。他们正在手动执行整合，这既耗时又容易出错。如果您的要求与他们的要求类似，则不希望用户选择文件；您希望流程完全自动化。我不再拥有为该客户机创建的代码，而是从内存中创建了一个简单的版本

我创建了一个工作簿，其中包含一个名为“说明”的工作表。他们有多个这样的工作表，因为他们有几个合并。然而，一个就足以说明这一原则。工作表有多行。每行指定从一个工作簿到另一个工作簿的范围复制。各栏分别为：

Source         Folder
range          Workbook name
               Worksheet name
               Left column      \
               Top row          |  Source range
               Right column     |
               Bottom row       /

Destination    Folder
range          Workbook name
               Worksheet name
               Top left destination cell

这是我的测试数据的图像：


注：本数据为设计数据