Dynamic sheet copy

[ma0ffst08]

Hi guys,

I want a macro that will copy a number of tabs across into a new workbook, and paste values.

However, the tabs which need pulling across will vary depending on what the user wants to bring across (although certain tabs will always need to be pulled across: "Summary", "Forecast", "Pictures").
Furthermore, the user may have created some new tabs (with no naming convention) which may also need pulling across.

Ideally when the macro is run, it would come up with a dialogue box with all the (unhidden) tabs listed, and a prompt:
"Which of these would you like to copy?" With a tick box against each one, but defaulted to 'yes' for the tabs that will always be pulled across: "Summary", "Forecast", "Pictures".

Is this possible??

If the default 'yes' option is not possible, is the tick box possible (with everything unticked)?

 

[bsquad]

are there multiple import workbooks?
ideally if you want to have a dynamic range of tabs, its best to have your "End workbook" or "Master workbook" listed with the tabs you want - thats just my perspective though.
if you want check mark boxes - you are then having to create forms which I think most end up to be a lot more work then the payoff.

IF you are pulling across multiple import workbooks; this should give you a start - without knowing more about what you'd like to copy besides the sheet names (and especially the ranges) I don't have code regarding any action - i.e. like copy or paste.

Sub CP()
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iWorkbook As Workbook
    Dim iSheet As Worksheet
    Dim iWorkbookImportOpen As Variant
    
    ChDir eWorkbook.Path
        iWorkbookImportOpen = Application.GetOpenFilename(filefilter:="Excel Workbooks (*.xlsx; *.xlsm),*.xlsx; *.xlsm", _
                    Title:="Select File", MultiSelect:=True)
                        On Error GoTo ExitSub
    For k = LBound(iWorkbookImportOpen) To UBound(iWorkbookImportOpen)
        Set iWorkbook = Workbooks.Open(Filename:=iWorkbookImportOpen(k), ReadOnly:=True)
        For x = 1 To iWorkbook.Worksheets.Count
            DoEvents
            Application.StatusBar = eWorkbook.Worksheets(x).Name
                Set iSheet = Nothing
                    On Error Resume Next
                Set iSheet = iWorkbook.Worksheets(eWorkbook.Worksheets(x).Name)
                    On Error GoTo 0
                    If TypeName(iSheet) <> "Nothing" Then
                        ''CODE
                    End If
        Next x
    Next k
        
End Sub

 

[ma0ffst08]

Hiya,

All of the tabs to be copied are in one workbook, called "Template".
I want to copy everything, although if there are formulas, I want it to paste values.

are there multiple import workbooks?
ideally if you want to have a dynamic range of tabs, its best to have your "End workbook" or "Master workbook" listed with the tabs you want - thats just my perspective though.
if you want check mark boxes - you are then having to create forms which I think most end up to be a lot more work then the payoff.

IF you are pulling across multiple import workbooks; this should give you a start - without knowing more about what you'd like to copy besides the sheet names (and especially the ranges) I don't have code regarding any action - i.e. like copy or paste.

Sub CP()
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iWorkbook As Workbook
    Dim iSheet As Worksheet
    Dim iWorkbookImportOpen As Variant
    
    ChDir eWorkbook.Path
        iWorkbookImportOpen = Application.GetOpenFilename(filefilter:="Excel Workbooks (*.xlsx; *.xlsm),*.xlsx; *.xlsm", _
                    Title:="Select File", MultiSelect:=True)
                        On Error GoTo ExitSub
    For k = LBound(iWorkbookImportOpen) To UBound(iWorkbookImportOpen)
        Set iWorkbook = Workbooks.Open(Filename:=iWorkbookImportOpen(k), ReadOnly:=True)
        For x = 1 To iWorkbook.Worksheets.Count
            DoEvents
            Application.StatusBar = eWorkbook.Worksheets(x).Name
                Set iSheet = Nothing
                    On Error Resume Next
                Set iSheet = iWorkbook.Worksheets(eWorkbook.Worksheets(x).Name)
                    On Error GoTo 0
                    If TypeName(iSheet) <> "Nothing" Then
                        ''CODE
                    End If
        Next x
    Next k
        
End Sub

 

[bsquad]

ok so I have it set to your three sheets ("Summary", "Forecast", "Pictures"), it will ignore any other sheets in either the Template workbook or import workbook. It will from A1 to the highest row with the highest column to the right of data, paste, - after the first paste it will continue to paste right below the previous one. So for instance, say you have data in your import workbook 1 Summary with data occupied from A1:F50, it will copy it, then paste it under the template workbook Summary to A1:F50, then lets say in import workbook 2 Summary you have data occupied from A1:F25, it will copy it, then the template workbook Summary pasting it STARTING in row A51. So in your template workbook Summary, you should have data from A1:F75.

you can adjust the worksheets you want to take by adding or removing in the Array
Dim iArraySheets As Variant
iArraySheets = Array("Summary", "Forecast", "Pictures")
you could also reference cells with the names of the worksheets as well. Creating a form with check marks goes beyond my limit without getting paid. - you could find someone who loves to create forms, but this should at least give you a good start. Hopefully this helps!

Sub CP()
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iWorkbook As Workbook
    Dim iSheet As Worksheet
    Dim iWorkbookImportOpen As Variant
    Dim iArraySheets As Variant
        iArraySheets = Array("Summary", "Forecast", "Pictures")
    Dim iER, iLR, eER As Long
    Dim LoopCount As Integer
        LoopCount = 1
        'LoopCount is per workbook, if you want to copy the same workbook x2 for whatever reason
    Application.AskToUpdateLinks = False: Application.DisplayAlerts = False: Application.ScreenUpdating = False
    ChDir eWorkbook.Path
        iWorkbookImportOpen = Application.GetOpenFilename(filefilter:="Excel Workbooks (*.xlsx; *.xlsm),*.xlsx; *.xlsm", _
                    Title:="Select File", MultiSelect:=True)
                        On Error Resume Next
    For k = LBound(iWorkbookImportOpen) To UBound(iWorkbookImportOpen)
        Set iWorkbook = Workbooks.Open(Filename:=iWorkbookImportOpen(k), ReadOnly:=True)
        For x = 1 To LoopCount
            DoEvents
            Application.StatusBar = eWorkbook.Worksheets(x).Name
                Set iSheet = Nothing
                    On Error Resume Next
                Set iSheet = iWorkbook.Worksheets(eWorkbook.Worksheets(x).Name)
                    On Error GoTo 0
                    If TypeName(iSheet) <> "Nothing" Then
                        For i = LBound(iArraySheets) To UBound(iArraySheets)
                        iWorkbook.Worksheets(iArraySheets(i)).Activate
                            iER = iWorkbook.Worksheets(iArraySheets(i)).Cells(Rows.Count, 1).End(xlUp).Row
                            iLR = iWorkbook.Worksheets(iArraySheets(i)).Cells(1, Columns.Count).End(xlToLeft).Column
                            With iWorkbook.Worksheets(iArraySheets(i))
                                .Range(Cells(1, 1), Cells(iER, iLR)).Copy
                            End With
                        eWorkbook.Worksheets(iArraySheets(i)).Activate
                            eER = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                            With eWorkbook.Worksheets(iArraySheets(i)).Cells(eER, 1)
                                .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            End With
                                Application.CutCopyMode = False
                        Next i
                    End If
        Next x
    Next k
Application.AskToUpdateLinks = True: Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub

 

[bsquad]

oh and you can remove the activate statements if you want, I was just using those to test.

 

[bsquad]

sorry, you really don't need the extra crap about the worksheet names matching since I have the array; I was just working from the previous one.
this should work perfectly fine

Sub CP2()
    Dim eWorkbook As Workbook
        Set eWorkbook = ThisWorkbook
    Dim iWorkbook As Workbook
    Dim iWorkbookImportOpen As Variant
    Dim iArraySheets As Variant
        iArraySheets = Array("Summary", "Forecast", "Pictures")
    Dim iER, iLR, eER As Long
    
    ChDir ThisWorkbook.Path
        iWorkbookImportOpen = Application.GetOpenFilename(filefilter:="Excel Workbooks (*.xlsx; *.xlsm),*.xlsx; *.xlsm", _
                    Title:="Select File", MultiSelect:=True)
                        On Error Resume Next
    For k = LBound(iWorkbookImportOpen) To UBound(iWorkbookImportOpen)
        Set iWorkbook = Workbooks.Open(Filename:=iWorkbookImportOpen(k), ReadOnly:=True)
            For i = LBound(iArraySheets) To UBound(iArraySheets)
            iWorkbook.Worksheets(iArraySheets(i)).Activate
                iER = iWorkbook.Worksheets(iArraySheets(i)).Cells(Rows.Count, 1).End(xlUp).Row
                iLR = iWorkbook.Worksheets(iArraySheets(i)).Cells(1, Columns.Count).End(xlToLeft).Column
                With iWorkbook.Worksheets(iArraySheets(i))
                    .Range(Cells(1, 1), Cells(iER, iLR)).Copy
                End With
            eWorkbook.Worksheets(iArraySheets(i)).Activate
                eER = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With eWorkbook.Worksheets(iArraySheets(i)).Cells(eER, 1)
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End With
                    Application.CutCopyMode = False
            Next i
    Next k
End Sub