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

本文介绍了VBA通过文件夹循环查找工作表打开它并将所有选项卡移动到另一个工作簿的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

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

我想要一个宏循环遍历一个文件夹并搜索某个工作表，然后抓住所有的这个工作表中的选项卡并将它们移动到合并的工作簿中

是否可以根据工作表名称中的某个字符串找到工作表？例如：Financial_data_401kk.xls

您可以通过此字符串401kk进行搜索吗？

这是我到目前为止

Sub ConsolidateSheets（） Dim Path as String Dim File As String Dim wb1 as Workbook，wb2 as Workbook Path =G：\Operations\test\ File = Dir （路径&* 401kk *）设置wb1 = Wworkbooks（book1.xlsm）设置wb2 =工作簿（文件）对于每个sh在wb2 sh.copy之后：= wb1.sheets（wb1.sheets.count）下一个 End Sub / pre>

解决方案

建立在这个你可以这样做。

密钥更新是这两行

  strFileName = Dir（strFolderName&\ * 401kk * .xl s *）
 strDefaultFolder =G：\Operations\test\

根据，因此只需要操作所需的工作簿。

代码

  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范围
 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 
 
'Shell对象使用默认目录所需的变量声明
 Dim strDefaultFolder As Variant 
 
 
 bProcessFolder = True 
 
 
'如果需要，设置默认目录
 strDefaultFolder =G：\Operations\test\
 
'如果用户将所有表格整理到单个目标表单中，则可以在此处设置行间距
'来区分不同的表单
 lrowSpace = 1 
 
如果bProcessFolder然后
 strFolderName = BrowseForFolder（strDefaultFolder）
'查找xls，xlsx，xlsm文件
 strFileName = Dir（strFolderName& \ * 401kk * .xls *）
 Else 
 strFileName =应用程序_ 
 .GetOpenFilename（选择要处理的文件（* .xls *），* .xls *）
如果
 
设置Wb1 = Workbooks.Add（1）
设置ws1 = Wb1.Sheets（1）
如果不是bNewSheet然后ws1.Range（A1： B1）= Array（工作簿名称，工作表计数）
 
'关闭屏幕更新，事件，警报并将计算设置为手动
应用程序
 .DisplayAlerts = False 
 .EnableEvents = False 
 .ScreenUpdating = False 
 lngCalc = .Calculation 
 .Calculation = xlCalculationManual 
 End with 
 
'set path在循环之外
 StrPrefix = strFolderName& IIf（bProcessFolder，\，vbNullString）
 
 Do While Len（strFileName）> 0 
'向用户
提供进度状态Application.StatusBar = Left（处理& strFolderName&\& strFileName，255）
'打开文件夹中的每个工作簿感兴趣
设置Wb2 = Workbooks.Open（StrPrefix& strFileName）
如果不是bNewSheet然后
'将摘要详细信息添加到第一个工作表
 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 
结束如果
对于每个ws2在Wb2.Sheets 
如果bNewSheet然后
'所有数据到单张
'跳过导入目标表数据如果源表是空的
设置rng2 = ws2.Cells.Find（*，ws2。[a1]，xlValues，xlByRows，xlPrevious）
 
如果不是rng2是没有，然后
设置rng1 = ws1.Cells.Find（*，ws1。[a1]，xlVa lue，xlByRows，xlPrevious）
'查找目标表上的第一个空白行
如果不是rng1不是然后
设置rng3 = ws2.Range（ws2.UsedRange.Cells（1） ，ws2.Cells（rng2.Row，A））
'确保目标工作表中的行区域不会被超过
如果rng3.Rows.Count + rng1.Row< Rows.Count Then 
'将每个源表的使用范围的数据复制到目标工作表的第一个空行
'，使用要复制的源表中的起始列地址
 ws2.UsedRange.Copy ws1.Cells（rng1.Row + 1 + lrowSpace，ws2.UsedRange.Cells（1）.Column）
 Else 
 MsgBox总结表大小已超过。 vbNewLine& _ 
sheet：& ws2.Name& vbNewLine& of& vbNewLine& 工作簿：& Wb2.Name 
 Wb2.Close False 
退出Do 
结束如果
'为任何间隔行的第一个颜色
如果lrowSpace<> 0然后ws1.Rows（rng1.Row + 1）.Interior.Color = vbGreen 
 Else 
'目标表是空的，所以复制到第一行
 ws2.UsedRange.Copy ws1.Cells 1，ws2.UsedRange.Cells（1）.Column）
 End If 
 End If 
 Else 
'每个源表的新目标表
 ws2.Copy after ：= Wb1.Sheets（Wb1.Sheets.Count）
'删除目标表中的任何链接
使用Wb1.Sheets（Wb1.Sheets.Count）.Cells 
 .Copy 
 .PasteSpecial xlPasteValues 
 End with 
 On Error Resume Next 
 Wb1.Sheets（Wb1.Sheets.Count）.Name = ws2.Name 
'工作表名称已存在于目标工作簿中
如果Err.Number<> 0然后
'向工作表名称添加一个数字，直到派生一个唯一的名称
 Do 
 lSht = lSht + 1 
设置ws3 = Wb1.Sheets（ws2.Name& & lSht）
循环而不是ws3是没有
 lSht = 0 
结束如果
错误GoTo 0 
结束如果
下一个ws2 
'关闭打开的工作簿
 Wb2.Close False 
'检查是否强制循环退出处理单个文件
如果bProcessFolder = False然后退出执行
 strFileName = Dir 
循环
 
'如果用户使用目标表，则删除任何链接
如果bNewSheet然后
带有ws1.UsedRange 
 .Copy 
 .Cells（1）.PasteSpecial xlPasteValues 
 .Cells（1）.Activate 
 End with 
 Else 
'Forma如果用户已经创建了单独的目标表，那么该摘要表
 ws1.Activate 
 ws1.Range（A1：B1）。Font.Bold = True 
 ws1.Columns.AutoFit 
结束如果
 
与应用程序
 .CutCopyMode = False 
 .DisplayAlerts = True 
 .EnableEvents = True 
 .ScreenUpdating = True 
 .Calculation = lngCalc 
 .StatusBar = vbNullString 
 End with 
 End Sub 
 
 
功能BrowseForFolder（可选OpenAt As Variant）As Variant 
 '从他的vbaexpress.com文章中使用的Ken Puls文章
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284 
 
 Dim ShellApp As Object 
'在默认文件夹
创建文件浏览器窗口设置ShellApp = CreateObject（Shell.Application）。 _ 
 BrowseForFolder（0，请选择一个文件夹，0，OpenAt）
 
'将文件夹设置为所选的文件夹。 （取消错误时）
错误恢复下一步
 BrowseForFolder = ShellApp.self.Path 
错误GoTo 0 
 
'销毁Shell应用程序
设置ShellApp = Nothing 
 
'检查无效或非条目，并发送到无效错误
'处理程序如果找到
'有效选择可以开始L：（其中L是一个字母）或
'\\（如\\servername\sharename中所有其他无效
选择Case Mid（BrowseForFolder，2，1）
 Case Is = ：
如果左（BrowseForFolder，1）=：然后GoTo无效
案例Is =\
如果不是左（BrowseForFolder，1）=\然后GoTo无效
案例Else 
 GoTo无效
结束选择
 
退出函数
 
无效：
'如果确定选择无效，设置为False 
 BrowseForFolder = False 
结束功能

I'm working on a project that requires the following:

I would like a Macro to loop through a folder and search for a certain worksheet then grab all the tabs from this worksheet and move them to a consolidated workbook

Is it possible to find a worksheet based on a certain string in the worksheet name? ex: Financial_data_401kk.xls

Could you search by this string "401kk"?

Im new to VBA and this is what i have so far

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

解决方案

Building on this EE article you could do this.

Key update are these two lines

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

The first point searches for your specific string with Dir as per Loop through files in a folder using VBA? so only the requireed workbooks are manipulated.

code

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

这篇关于VBA通过文件夹循环查找工作表打开它并将所有选项卡移动到另一个工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！