☰

VBA 代码将文件夹中保存的某些工作表从已关闭的工作簿复制到全新的工作簿

tag-icon • tag-icon vba microsoft-excel-2013
VBA 代码将文件夹中保存的某些工作表从已关闭的工作簿复制到全新的工作簿

我希望有一种方法可以解决我目前手动执行的一个非常耗时的过程。

我收集了 30 多个向我发送 Excel（xlsx 格式）的人的意见。到目前为止，我已经打开每个文件，找到以特定方式命名的工作表（例如，查找名称中包含单词“Plan”的工作表），将找到的工作表复制到一个全新的工作簿中，并将新创建的工作簿保存在指定位置。

这个过程可以通过使用宏来实现自动化吗？理想情况下，我希望有一个宏可以复制工作表名称中包含“plan”的工作表，而无需打开多个工作簿，复制保存在单个文件夹中的所有文件中找到的选定工作表，并将这些工作表粘贴到全新的工作簿中。这可以实现吗？

我有下面的代码，但当我运行这个宏时，什么都没有发生。你能看出是什么导致了这个问题吗？

Sub CopyWorkSheets(strDirectory As String, strSheetName As String)
    Dim xlThisWB As Workbook
    Dim xlWB As Workbook
    Dim xlWS As Worksheet
    Dim strFileName As String
    Dim iCount As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    On Error Resume Next

    Set xlThisWB = ThisWorkbook
    strFileName = Dir(strDirectory & "*.xlsx")
    Do While strFileName <> ""
        If strFileName <> xlThisWB.Name Then
            With xlThisWB
                Set xlWB = Workbooks.Open(Filename:=strDirectory & strFileName)
                Set xlWS = xlWB.Worksheets(strSheetName)
                xlWS.Copy after:=xlThisWB.Worksheets(xlThisWB.Worksheets.Count)
                xlWB.Close
            End With
        End If
        strFileName = Dir()
    Loop
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

答案1

在新的标准模块中添加下面的过程并执行 CopyWorkSheets()：

运行后，您会在目标文件夹中看到一个新文件Plans 2017-07-27 07-30.xlsx（基于日期）

Option Explicit

Public Sub CopyWorkSheets()
    Const PATH_FROM = "D:\Test1\"    '<- Update source folder path
    Const PATH_DEST = "D:\Test2\"    '<- Update destination path

    Dim wb As Workbook, ws As Worksheet, wbResult As Workbook, fName As String, x As String

    If Len(Dir(PATH_FROM, vbDirectory)) > 0 And Len(Dir(PATH_DEST, vbDirectory)) > 0 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set wbResult = GetNewWB

        fName = Dir(PATH_FROM & "*.xlsx")
        Do While Len(fName) > 0
            x = PATH_FROM & fName
            Set wb = Workbooks.Open(Filename:=x, UpdateLinks:=False, ReadOnly:=True)
            For Each ws In wb.Worksheets
                If InStr(1, ws.Name, "Plan", vbTextCompare) > 0 Then
                    ws.Copy After:=wbResult.Worksheets(wbResult.Worksheets.Count)
                End If
            Next
            wb.Close SaveChanges:=False
            fName = Dir()
        Loop

        fName = PATH_DEST & "Plans " & Format(Now, "yyyy-mm-dd hh-mm") & ".xlsx"
        SaveNewPlans wbResult, fName
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

Private Function GetNewWB() As Workbook
    Dim wb As Workbook, newSheets As Long

    newSheets = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set wb = Workbooks.Add
    Application.SheetsInNewWorkbook = newSheets
    Set GetNewWB = wb
End Function

Private Sub SaveNewPlans(ByRef wb As Workbook, ByVal fName As String)
    With Application
        .DisplayAlerts = False
        With wb
            .Worksheets(1).Delete
            .Worksheets(1).Activate
            .SaveAs fName
            .Close SaveChanges:=False
        End With
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

您的初始代码应该用类似的行来调用CopyWorkSheets "D:\Test1\", "FileName.xlsx"，但它不会遍历所有文件，也不会查找名称中包含“Plans”的工作表名称

相关内容