Selecting Variable Tabsheets in Different Workbook

[Thomazz]

It has been a while since I needed to ask a question, but here I am again ...

Don't think it's hard, but have been working on this for two days already and it's starting to annoy me. I will explain as good as I can.

I have a workbook, let's call it the source workbook. There is a range of cells (let's say C2 till E2) that all have tabnames from a different workbook in there (these are filled in by the user). Let's use the names Brazil, USA and China as an example.

I want VBA to go to a different workbook ("Actual Data"), select the 3 tabsheets there (Brazil, USA, China) and copy it to a new workbook.

Difficulty might be : the range of cells can be different in length. It might be two cells (C2 till D2) depending on how many cells my user has filled in.

That's my main problem.


What my macro also does, is go to the next row in the source workbook, and do the same thing for the next row (so take a range, for this example C3 till F3, go back to the Actual Data file, copy these 4 tabsheets to a new workbook and so on ...

Anybody that can help me here ? My eternal gratitude.

 

[Thomazz]

I’m out of the office now, if you had supplied all the info you needed the code to do at the beginning it would have been more helpful. I will look into this later when I get a chance.

No problem. I should have been more clearer, but I'm not always easy in explaining my problems. Entirely my fault.

 

[Thomazz]

Here's a bonus if you get tired of closing workbooks:

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Closes all workbooks except this one (ThisWorkbook).           '
' Returns:      The number of closed workbooks.                                '
' Remarks:      Caution: The changes on those other workbooks will be lost.    '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function closeWorkbooks(Optional closeHidden As Boolean = False) As Long
    Dim wb As Workbook, i As Long
    Application.ScreenUpdating = False
    For Each wb In Workbooks
        If Not wb Is ThisWorkbook Then
            If Not closeHidden Then
                If Windows(wb.Name).Visible Then
                    wb.Close False
                    closeWorkbooks = closeWorkbooks + 1
                End If
            Else
                wb.Close False
                closeWorkbooks = closeWorkbooks + 1
            End If
        End If
    Next wb
    Application.ScreenUpdating = True
    Exit Function
End Function

Sub USEcloseWorkbooks()
    closeWorkbooks
End Sub
'Or
Sub USEcloseWorkbooks2()
    Dim num As Long
    num = closeWorkbooks
    MsgBox "Closed " & num & " workbooks."
End Sub

Works like a charm ! The only open item I have (but that's only to improve efficiency). It now created a bunch of workbooks that stayed open under their random name.

Would it be possible to save them in a specific path (let's say I have that directory stored in cell A2). I would like to give it the name that is also stored in the rows, in column B.

 

[Thomazz]

Works like a charm ! The only open item I have (but that's only to improve efficiency). It now created a bunch of workbooks that stayed open under their random name.

Would it be possible to save them in a specific path (let's say I have that directory stored in cell A2). I would like to give it the name that is also stored in the rows, in column B.

Maybe I was not fully clear (again) : so in the rows I have the tabs that need to be copied (as you already did in your VBA, in column C and following. The name under which the WB needs to be saved is stored in that some row, but in Column B (for example it would be Europe, so it would end up as Europe.xls and stored under the folder that I defined in cell A2.

 

[VBasic2008]

Works like a charm ! The only open item I have (but that's only to improve efficiency). It now created a bunch of workbooks that stayed open under their random name.

Would it be possible to save them in a specific path (let's say I have that directory stored in cell A2). I would like to give it the name that is also stored in the rows, in column B.

Of course it is. But you have to do it in the With Workbooks block. I'm busy at the moment, but I'll look into it. BTW the whole idea is pretty cool.

 

[Thomazz]

Thanks for your appreciated help. Will keep an eye on this topic

 

[VBasic2008]

Here is the code including the requested implementation.
Be aware that It automatically overwrites.
I have chosen the .xlsx format. If it is another then try this XlFileFormat enumeration (Excel) .

Sub copyTabSheets2()
    
    ' Define constants.
    
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Const FirstCol As Variant = "C"
    Const wbAddress As String = "A1" ' in the same Worksheet.
    Const foAddress As String = "A2" ' in the same Worksheet.
    
    ' Define First Column Range (of sheet names) ('rng').
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(wsName)
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, FirstCol).End(xlUp).Row
    If LastRow < FirstRow Then
        Exit Sub
    End If
    
    Dim rng As Range
    Set rng = ws.Range(ws.Cells(FirstRow, FirstCol), _
                         ws.Cells(LastRow, FirstCol))
    
    ' Write sheet names to arrays of Data Array ('Data').
    
    Dim ArraysCount As Long
    ArraysCount = rng.Rows.Count
    
    Dim Data As Variant
    ReDim Data(1 To ArraysCount)
    Dim FileNames As Variant
    ReDim FileNames(1 To ArraysCount)
    Dim FolderPath As String
    ' If the paths contain the trailing backslash ('\'),
    ' then remove ' & Application.PathSeparator'.
    FolderPath = ws.Range(foAddress).Value & Application.PathSeparator
    
    Dim n As Long
    Dim m As Long
    
    ' Note: There can be empty rows ('m'), but not empty columns.
    For n = 1 To ArraysCount
        With rng.Cells(n)
            If .Value <> "" Then
                m = m + 1
                FileNames(m) = FolderPath & .Offset(, -1).Value ' C to B = -1
                If .Offset(, 1).Value <> "" Then
                    Data(m) = Application.Transpose(Application.Transpose( _
                      .Resize(, .End(xlToRight).Column - .Column + 1).Value))
                Else
                    Data(m) = .Value
                End If
            End If
        End With
    Next n
    
    ' Create workbooks.
    
    ' Note: The worksheets can only be in order as they were before.
    Application.ScreenUpdating = True
    With Workbooks.Open(ws.Range(wbAddress).Value)
        For n = 1 To m
            .Sheets(Data(n)).Copy
            With ActiveWorkbook
                ' 'DisplayAlerts' allows automatically overwriting.
                Application.DisplayAlerts = False
                .SaveAs FileName:=FileNames(n), _
                                  FileFormat:=xlOpenXMLWorkbook
                .Close
                Application.DisplayAlerts = True
            End With
        Next n
        .Close SaveChanges:=False
    End With
    Application.ScreenUpdating = True
    
    ' Inform user.
    
    MsgBox "Workbooks created.", vbInformation, "Success"
    
End Sub

 

[Thomazz]

Works perfect ! My eternal gratitude !