如何在一个工作簿中从多个工作簿中移动或复制以相同名称开头的工作表

Question

I have 4 excel workbooks each containing 35 sheets. Each workbook have one sheet where, the first there character of the sheet name is same in all the workbooks. For example: tes_8,tes_9,tes_3,tes_2 are sheet names in workbook1,workbook2,workbook3 and workbook4 respectively.

Now I want to copy sheets with sheet name having the first three character same from these four workbooks into a single workbook, so here I want a new excel workbook containing these four sheets: tes_8,tes_9 tes_3,tes_2

I was attempting to do this manually ie by right clicking on the sheet then,select move or copy option then,check the create a copy checkbox and then select the workbook you want your sheet to move to. Since there are 35 sheets moving manually is taking a lot of time.

Answer 1

You can try the below example code:

Set closedBook = Workbooks.Open("Destination workbook location")

For i = 1 To Worksheets.Count

select case left(Worksheets(i).Name,5) '' As your sheet name is 5 letters (tes_8,tes_9)

case tes_8,tes_9 tes_3,tes_2 '' checking whether it is in the start of sheet names

worksheets(i).Copy Before:=closedBook.Sheets(1) '' copy those sheets to destination workbook

closedBook.Close SaveChanges:=True

end select

Next i

I'm new in this community. I hope you can use it to create a vba program.

Answer 2

Copy Worksheets That Start With... to New Workbook

• In all (source) workbooks from the list (adjust), it will locate the first worksheet whose name starts with tes_ (adjust) and copy it to a new (destination) workbook.
• If a source workbook is open it will leave it open, if not, using the path C:\Test (adjust), it will open it and close it after copying the worksheet.

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