Question

我有一个包含100多个工作簿的文件夹。这些工作簿包含一系列数据。为简单起见，我将调用数据范围A1：D2，该范围位于所有100多个工作簿的Sheet1上。

我还有一份摘要工作簿。

我想将VBA代码放在循环文件夹的Summary工作簿中，复制100多个工作簿中每个工作簿的范围A1：D2。

然后，我想将每个工作簿中的A1：D2范围粘贴到“摘要”工作簿的“Sheet1”中。每个粘贴将从下一个未使用的行开始。

我现在很难通过手动过程这样做，这让我疯了。

我确实知道一些基本的VBA编码，但我的问题是我无法弄清楚如何正确地循环它，并且我不得不编写每个单独的工作簿以打开 - > gt; copy - ＆gt; paste- - ＆GT;关闭。这对于10-20个工作簿来说很好，但是现在我已经达到了100多个并且每周都在增长。

再次感谢，

布赖恩

Answer 1

我有一些东西可以满足您的要求，如果您想复制多个工作簿，我建议您创建一个新工作表，将工作簿信息捕获到电子表格中。以下说明

创建一个新工作表并为其命名，在这种情况下，我们将调用工作表'Control'
在VBA中创建一个新模块并使用下面的代码来操作工作簿副本

我已经留下了一段让你为你想要执行的功能编写代码。

Sub WorkbookConsolidator（）

Dim WB As Workbook, wb1 as workbook
Dim WBName as Range 
Dim folderselect as Variant, wbA as Variant, wbB as Variant, 
Dim I as long, J as long
Dim objFolder As Object, objFile As Object
Dim WBRange as String

'Set Core Variables and Open Folder containing workbooks.

 Set WB = ThisWorkbook
 Worksheets("Control").Activate
 Set FolderSelect = Application.FileDialog(msoFileDialogFolderPicker)
 FolderSelect.AllowMultiSelect = False
 MsgBox ("Please Select the Folder containing your Workbooks")
 FolderSelect.Show
 WBRange = FolderSelect.SelectedItems(1)
 Set objFolder = objFSO.GetFolder(FolderSelect.SelectedItems(1))


' Fill out File name Fields in Control Sheet 
' The workbook names will be captured in Column B
' This allows allocation for up to 100 workbooks
For I = 1 To 100
    For Each objFile In objFolder.files
    If objFile = "" Then Exit For
       Cells(I, 2) = objFile.Name ' Workbook Name
       Cells(I, 3) = WBRange ' Workbook Path
       I = I + 1
       Next objFile
    Next I

'Loop through the list of workbooks created in the 'Control' Directory, adjust the loop range as preferred
For J = 100 To 1 Step -1
      With Workbooks(ThisWorkbook).Worksheets("Control")
         BookLocation = .Range("C" & J).Value
         BookName = .Range("B" & J).Value
      End With

    Set wb1 = Workbooks.Open(Booklocation & Bookname)

    ' Write your code here'



       CleanUp:
       wb1.Close SaveChanges:=False

Next J

End Sub()

`

Answer 2

试试这个

Sub combine_into_one()
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim strPath$, Pivot$, sUserName$, sFolderName$, sSourceName$, x&
Dim oFldialog As FileDialog
Dim oFile As Scripting.File
Dim oFolder

Set oFldialog = Application.FileDialog(msoFileDialogFolderPicker)

With oFldialog
    If .Show = -1 Then
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        sFolderName = .SelectedItems(1)
    End If
End With

Set oFolder = FSO.GetFolder(sFolderName)

Workbooks.Add: Pivot = ActiveWorkbook.Name 'Destination workbook

For Each oFile In oFolder.Files
    Workbooks(Pivot).Activate

    x = Workbooks(Pivot).Sheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row + 1

    Workbooks.Open filename:=oFile: sSourceName = ActiveWorkbook.Name
    Workbooks(sSourceName).Activate
        Workbooks(sSourceName).Sheets("Sheet1").[A1:D1].Copy

    Workbooks(Pivot).Activate
    Workbooks(Pivot).Sheets("Sheet1").Cells(x, 1).PasteSpecial xlPasteAll
    Workbooks(sSourceName).Close False
Next

End Sub

从文件夹中的多个工作簿复制范围到文件夹中的摘要工作簿？

2 个答案: