VBA循环浏览文件夹查找工作表打开它并将所有选项卡移动到另一个工作簿

我正在开发一个需要以下项目的项目：

我想要一个macros来遍历一个文件夹并search某个工作表，然后从这个工作表中获取所有的选项卡，并将它们移动到一个整合的工作簿

是否有可能find一个基于工作表名称中的某个string的工作表？ 例如：Financial_data_401kk.xls

你能search这个string“401kk”吗？

即时通讯新的VBA，这是我到目前为止

Sub ConsolidateSheets() Dim Path as String Dim File As String Dim wb1 as Workbook, wb2 as Workbook Path = "G:\Operations\test\" File = Dir(Path & "*401kk*") Set wb1 = Wworkbooks("book1.xlsm") Set wb2 = Workbooks(File) For Each sh in wb2 sh.copy After:=wb1.sheets(wb1.sheets.count) Next End Sub 

Answer 1

build立在这个EE文章，你可以做到这一点。

关键更新是这两行

 strFileName = Dir(strFolderName & "\*401kk*.xls*") strDefaultFolder = "G:\Operations\test\" 

第一个要点使用Dirsearch您的特定string，并使用VBA循环访问文件夹中的文件？ 所以只有需要的工作簿被操纵。

码

 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 = True 'set default directory here if needed strDefaultFolder = "G:\Operations\test\" '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 & "\*401kk*.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 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 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

您可以操纵以下内容来满足您的需求。 在if语句中添加多个OR子句，并适当调整文件夹path！ 它会将工作表传输到正在执行代码的工作簿中！

 Sub main() Dim fso As New Scripting.FileSystemObject Dim file As Scripting.file Dim fldr As Scripting.Folder Dim wb As Excel.Workbook Set fldr = fso.GetFolder("c:\excelfiles\") Dim target As String Dim cwb As Workbook Set cwb = ActiveWorkbook For Each file In fldr.Files() target = file.Name If file.Name = "tasks.xlsx" Then i = 1 Application.Workbooks.Open (fldr.Path & "\" & file.Name) Set wb = Application.Workbooks(target) For Each sht In wb.Sheets If wb.Sheets(i).Name = "home" Then wb.Sheets(i).Copy after:=cwb.Sheets(1) i = i + 1 End If Next End If Next Set wb = Nothing Set file = Nothing Set fldr = Nothing Set xls = Nothing Set fso = Nothing End Sub