macros循环遍历两个命名表之间的所有表单，并将其数据复制到一个整合文件

我有一个模板文件，将被发送到我公司的所有子公司。

1. 该模板有一个名为start的选项卡和一个名为end的选项卡。
2. 子公司将在这两个名称表之间放置可变数量的模板提交表，并将其发送给我，以合并到我的合并文件中的一个表中。
3. 我写了macros来复制每个工作表到合并文件，但我目前需要运行一张一张，因为我不知道如何循环。
4. 复制macros位于我的Personal.xls文件中，粘贴macros位于合并表单中。
5. 循环macros需要在源文件 （可以是任何名称）和名为Consolidation.xls的合并文件之间工作。
6. 一旦所有工作表都从源文件复制，然后打开下一个源文件并重新开始，所以macros需要忘记旧的源文件并记住新文件。

如果我能得到一个macros的工作，这可以每周节省我几个小时，所以任何帮助非常赞赏。

Answer 1

我认为这是你所追求的。 如果所有的模板都在一个文件夹中 ，并且每个模板都有一个“开始”和“结束”表单，那么这个代码会将它们整理到

• 为每个模板中的每个相关工作表创build一个新的工作簿
• 在新的工作簿中放入一张工作表

我已将“从一个或多个工作簿整理工作表到一个摘要文件”中的代码更新为http://www.experts-exchange.com/A_2804.html，以满足您的“开始”和“结束”工作表

如果您需要（或有）更多的细节请发布

Public Sub ConsolidateSheets() Dim Wb1 As Workbook Dim Wb2 As Workbook Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim rng1 As Range Dim rng2 As Range Dim rng3 As Range Dim rngArea As Range Dim lrowSpace As Long Dim lSht As Long Dim lngCalc As Long Dim lngRow As Long Dim lngCol As Long Dim X() Dim bProcessFolder As Boolean Dim bNewSheet As Boolean Dim StrPrefix Dim strFileName As String Dim strFolderName As String 'variant declaration needed for the Shell object to use a default directory Dim strDefaultFolder As Variant bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes) bNewSheet = (MsgBox("Extract all data to a single sheet (Yes)," & vbNewLine & "or a target file sheet for each source sheet (No)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes) If Not bProcessFolder Then If Not bNewSheet Then MsgBox "There isn't much point creating a exact replica of your source file :)" Exit Sub End If End If 'set default directory here if needed strDefaultFolder = "C:\" 'If the user is collating all the sheets to a single target sheet then the row spacing 'to distinguish between different sheets can be set here lrowSpace = 1 If bProcessFolder Then strFolderName = BrowseForFolder(strDefaultFolder) 'Look for xls, xlsx, xlsm files strFileName = Dir(strFolderName & "\*.xls*") Else strFileName = Application _ .GetOpenFilename("Select file to process (*.xls*), *.xls*") End If Set Wb1 = Workbooks.Add(1) Set ws1 = Wb1.Sheets(1) If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count") 'Turn off screenupdating, events, alerts and set calculation to manual With Application .DisplayAlerts = False .EnableEvents = False .ScreenUpdating = False lngCalc = .Calculation .Calculation = xlCalculationManual End With 'set path outside the loop StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString) Do While Len(strFileName) > 0 'Provide progress status to user Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255) 'Open each workbook in the folder of interest Set Wb2 = Workbooks.Open(StrPrefix & strFileName) If Not bNewSheet Then 'add summary details to first sheet ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count End If For Each ws2 In Wb2.Sheets If ws2.Index > Wb2.Sheets("start").Index And ws2.Index < Wb2.Sheets("end").Index Then If bNewSheet Then 'All data to a single sheet 'Skip importing target sheet data if the source sheet is blank Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious) If Not rng2 Is Nothing Then Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious) 'Find the first blank row on the target sheet If Not rng1 Is Nothing Then Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A")) 'Ensure that the row area in the target sheet won't be exceeded If rng3.Rows.Count + rng1.Row < Rows.Count Then 'Copy the data from the used range of each source sheet to the first blank row 'of the target sheet, using the starting column address from the source sheet being copied ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column) Else MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _ "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name Wb2.Close False Exit Do End If 'colour the first of any spacer rows If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen Else 'target sheet is empty so copy to first row ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column) End If End If Else 'new target sheet for each source sheet ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count) 'Remove any links in our target sheet With Wb1.Sheets(Wb1.Sheets.Count).Cells .Copy .PasteSpecial xlPasteValues End With On Error Resume Next Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name 'sheet name already exists in target workbook If Err.Number <> 0 Then 'Add a number to the sheet name till a unique name is derived Do lSht = lSht + 1 Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht) Loop While Not ws3 Is Nothing lSht = 0 End If On Error GoTo 0 End If End If Next ws2 'Close the opened workbook Wb2.Close False 'Check whether to force a DO loop exit if processing a single file If bProcessFolder = False Then Exit Do strFileName = Dir Loop 'Remove any links if the user has used a target sheet If bNewSheet Then With ws1.UsedRange .Copy .Cells(1).PasteSpecial xlPasteValues .Cells(1).Activate End With Else 'Format the summary sheet if the user has created separate target sheets ws1.Activate ws1.Range("A1:B1").Font.Bold = True ws1.Columns.AutoFit End If With Application .CutCopyMode = False .DisplayAlerts = True .EnableEvents = True .ScreenUpdating = True .Calculation = lngCalc .StatusBar = vbNullString End With End Sub Function BrowseForFolder(Optional OpenAt As Variant) As Variant 'From Ken Puls as used in his vbaexpress.com article 'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284 Dim ShellApp As Object 'Create a file browser window at the default folder Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) 'Set the folder to that selected. (On error in case cancelled) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 'Destroy the Shell Application Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error 'handler if found 'Valid selections can begin L: (where L is a letter) or '\\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Exit Function Invalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = False End Function 

Answer 2

如果你真的需要帮助，你应该给我们看一些代码。

但据我了解你的问题，这里有一些提示或链接。

代码片段循环工作表

 Dim wkbkorigin As Workbook Dim ws As Worksheet Set wkbkorigin = Workbooks.Open("C:\bookB.xls") For Each ws In wkbkorigin.Worksheets 'do whatever Next 

一些关于这个问题的stackoverflow线程

• excel vba通过工作表循环，并根据input设置值
• 我怎样才能循环工作表的一个子集？

有关从文件获取信息的更多提示

看到这个有价值的线程： 通过VBA从另一个工作簿复制数据

你会发现有关的信息：

• 如何使用Excel对象模型将数据从文件复制到另一个文件
• 使用GetInfoFromClosedFile（）函数

Answer 3

一旦你根据JMax响应定义了工作簿/工作表，我想你正在寻找以下…

  IncludeSheet=0 For n = 1 to wkbkOrigin.Worksheets.Count If wkbkOrigin.Sheets(n).Name = "End" Then IncludeSheet = 0 End If If IncludeSheet = 1 Then Set ws = wkbkOrigin.Sheets(n) 'do whatever End If If wkbkOrigin.Sheets(n).Name = "Start" Then IncludeSheet = 1 End If Next n 

关键是引入一个标志variables来告诉你是否在工作簿的正确部分，在这种情况下是IncludeSheet