CODEWITHSUNDEEP
vbaexcel
Jess Murray
Jess Murray

Reputation: 1339

Move specific tab from multiple workbooks into a single workbook

I have multiple workbooks which all have the tab named "example". I am wanting to adjust my current file to check if the current sheet is named "example", add the name of the workbook in front of "example" e.g. "File1 example" and move this tab into another file.

Currently i have the below, which pulls all tabs from all workbooks into a new workbook. 

Sub GetSheets()
Path = "C:\TestPath\"
Filename = Dir(Path & "*.xls")

MsgBox (Filename)

Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
      Next Sheet
         Workbooks(Filename).Close
         Filename = Dir()
      Loop
End Sub

Upvotes: 0

Views: 217

Answers (2)

Pᴇʜ
Pᴇʜ

Reputation: 57743

Instead of looping through all sheets of a workbook you can just access it directly if you already know its name.

Also make sure not to exceed the max length that is allowed for a worksheet name. This is 31 characters so trim the workbook name or you might run into errors.

Public Sub GetSheets()
    Dim Path As String
    Path = "C:\TestPath\"

    Dim Filename As String
    Filename = Dir(Path & "*.xls")

    Dim ws As Worksheet

    MsgBox (Filename)

    Dim OpenWb As Workbook
    Do While Filename <> ""
        Set OpenWb = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
        OpenWb.Worksheets("example").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'copy after last sheet
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Left$(OpenWb.Name, 31) 'don't exceed max allowed length

        OpenWb.Close False 'we do not save changes in the opened Workbook
        Filename = Dir()
    Loop
End Sub

Note an error handling might be needed if there is a possibility that any of the files has no worksheet named example.

Upvotes: 2

Foxfire And Burns And Burns
Foxfire And Burns And Burns

Reputation: 11988

Something like this should work for you.

Sub GetSheets()

Path = "C:\TestPath\"
Filename = Dir(Path & "*.xls")

Dim ws As Worksheet

MsgBox (Filename)


Do While Filename <> ""
    Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
    For Each ws In ActiveWorkbook.Sheets
        If ws.Name = "example" Then 'name of tab
            ws.Name = ws.Name & " " & ActiveWorkbook.Name
            ws.Copy After:=ThisWorkbook.Sheets(1)
            Exit For
        End If
    Next ws
    Workbooks(Filename).Close False 'we do not save changes in the opened Workbook
    Filename = Dir()
Loop
End sub

Upvotes: 1

Related Questions