如何在一個工作簿中從多個工作簿中移動或復制以相同名稱開頭的工作表

Question

我有 4 個 excel 工作簿，每個工作簿包含 35 張。 每個工作簿都有一個工作表，其中工作表名稱的第一個字符在所有工作簿中都相同。 例如： tes_8,tes_9,tes_3,tes_2 分別是 workbook1、workbook2、workbook3 和 workbook4 中的工作表名稱。

現在我想將這四個工作簿中前三個字符相同的工作表名稱復制到一個工作簿中，所以在這里我想要一個包含這四個工作表的新 excel 工作簿：tes_8,tes_9 tes_3,tes_2

我試圖手動執行此操作，即通過右鍵單擊工作表然后，select 移動或復制選項，然后選中創建副本復選框，然后選中 select 您希望工作表移動到的工作簿。 由於手動移動 35 張紙需要很多時間。

Answer 1

您可以嘗試以下示例代碼：

Set closedBook = Workbooks.Open("目標工作簿位置")

對於 i = 1 到 Worksheets.Count

select case left(Worksheets(i).Name,5) '' 因為您的工作表名稱是 5 個字母 (tes_8,tes_9)

case tes_8,tes_9 tes_3,tes_2 '' 檢查是否在工作表名稱的開頭

worksheets(i).Copy Before:=closedBook.Sheets(1) '' 將這些工作表復制到目標工作簿

closedBook.Close SaveChanges:=True

結束 select

接下來我

我是這個社區的新手。 我希望你可以用它來創建一個 vba 程序。

Answer 2

將以...開頭的工作表復制到新工作簿

• 在列表 (adjust) 中的所有（源）工作簿中，它將找到名稱以tes_開頭的第一個工作表（adjust）並將其復制到新的（目標）工作簿中。
• 如果源工作簿打開，它將保持打開狀態，如果沒有，使用路徑C:\Test （調整），它將在復制工作表后打開並關閉它。

Option Explicit

Sub CopyWorksheets()
    
    ' Define constants.
    Const swbNamesList As String = "wb1.xlsx,wb2.xlsx,wb3.xlsx,wb4.xlsx"
    Const sFolderPath As String = "C:\Test"
    Const swsNameLeft As String = "tes_"
    
    ' Determine and validate the source path ('sPath').
    Dim sPath As String: sPath = Dir(sFolderPath, vbDirectory)
    If Len(sPath) = 0 Then
        MsgBox "The path '" & sFolderPath & "' was not found.", vbCritical
        Exit Sub
    End If
    sPath = sFolderPath
    If Right(sPath, 1) <> Application.PathSeparator Then
        sPath = sPath & Application.PathSeparator
    End If
    
    ' Write the source workbook names from the list to an array ('swbNames').
    Dim swbNames() As String: swbNames = Split(swbNamesList, ",")
    
    Application.ScreenUpdating = False
    
    ' Declare variables used for the first time
    ' in the following For...Next loop.
    Dim swb As Workbook ' Current Source Workbook
    Dim sws As Worksheet ' Current Source Worksheet
    Dim swbPath As String ' Current Source Path
    Dim swbWasClosed As Boolean ' Closed Boolean
    Dim dwb As Workbook ' Destination Workbook
    Dim dwsCount As Long ' Destination Worksheets Count
    Dim n As Long ' Source Workbook Names Counter
    
    ' Loop through the elements of the array.
    For n = 0 To UBound(swbNames)
        ' Attempt to reference the source workbook.
        On Error Resume Next
            Set swb = Workbooks(swbNames(n))
        On Error GoTo 0
        If swb Is Nothing Then ' the source workbook is not open
            ' Attempt to open the source workbook.
            swbPath = sPath & swbNames(n)
            On Error Resume Next
                Set swb = Workbooks.Open(swbPath)
            On Error GoTo 0
            swbWasClosed = True
        'Else ' the source workbook is open
        End If
        If Not swb Is Nothing Then ' the source workbook is open
            For Each sws In swb.Worksheets
                If InStr(1, sws.Name, swsNameLeft, vbTextCompare) = 1 Then
                    If dwsCount = 0 Then
                        sws.Copy ' creates a new single-worksheet workbook
                        Set dwb = Workbooks(Workbooks.Count) ' reference it
                    Else
                        sws.Copy After:=dwb.Sheets(dwb.Sheets.Count)
                    End If
                    dwsCount = dwsCount + 1
                    Exit For ' stop looping because the worksheet was found
                'Else ' not a match; do nothing
                End If
            Next sws
            If swbWasClosed Then ' the source workbook was closed
                swb.Close SaveChanges:=False
                swbWasClosed = False ' reset the variable
            'Else ' the source workbook was open, let it be; do nothing
            End If
            Set swb = Nothing ' reset the variable
        'Else ' the source file (workbook) doesn't exist; do nothing
        End If
    Next n

    If dwsCount > 0 Then dwb.Saved = True ' just for easy closing while testing

    Application.ScreenUpdating = True
    
    ' Inform.
    Select Case dwsCount
    Case 0
        MsgBox "No worksheets found.", vbCritical
    Case 1
        MsgBox "Only one worksheet found.", vbExclamation
    Case n
        MsgBox "All " & n & " worksheets found.", vbInformation
    Case Else
        MsgBox "Only " & dwsCount & " worksheets found.", vbExclamation
    End Select

End Sub