Using VBA to Copy a Group of Sheets to a New Workbook

[gpippin84]

I'm trying to copy groups of sheets to a new workbook using VBA. But the number of sheets in a group can change depending on a criterion. I have the names of the sheets that I would like to grab, stored in referenced cells.

Is there a way to "stop" after the last cell with a value? If I have 10 cells that are in the range but only 5 have values, how can I have the VBA only select the 5 with values and use that as my range?

My current code works but is still very manual.

Sub ExportBranch()

    Dim FirstSheet As String
    With ActiveSheet
        FirstSheet = .Range("B279").Value
        End With
    Dim SecondSheet As String
    With ActiveSheet
        SecondSheet = .Range("B280").Value
        End With
    Dim ThirdSheet As String
    With ActiveSheet
        ThirdSheet = .Range("B281").Value
        End With
    Dim FourthSheet As String
    With ActiveSheet
        FourthSheet = .Range("B282").Value
        End With
    Dim FifthSheet As String
    With ActiveSheet
        FifthSheet = .Range("B283").Value
        End With
        
    Sheets(Array(FirstSheet, SecondSheet, ThirdSheet, FourthSheet, FifthSheet)).Copy
    



'2nd Half of macro that copy and pastes values and saves the file

    Sheets(SecondSheet).Select
    Range("C264:N273").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C134:N140").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets(SecondSheet).Select
    Dim fname As String
    With ActiveSheet
        fname = .Range("B284").Value
    ActiveWorkbook.SaveAs Filename:= _
        "\\server\folder\folder\2018 Folders & WP\2018 Budget\#Export Files\" & fname, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWindow.Close
    End With


End Sub

Thank you in advance!

gpippin84

 

[Fluff]

Hia

If I have 10 cells that are in the range but only 5 have values

will the x cells with values always be the first x cells as in your code, or could you have values in first 4 cells then a blank & then more values

 

[gpippin84]

it will always have blank cells last. Not blanks in the middle.

thanks,

 

[Fluff]

Give this a go

    Dim UsdRws As Integer
    Dim Cnt As Integer
    Dim Rng As Range
    Dim OrigWb As Workbook
    Dim NewWb As Workbook

    Set OrigWb = ThisWorkbook
    
    With ActiveSheet
        UsdRws = .Range("B279").End(xlDown).Row
        Set Rng = .Range("B279:B" & UsdRws)
    End With
    
    Sheets(Rng.Cells(1, 1).Value).Copy
    Set NewWb = ActiveWorkbook
    For Cnt = 2 To UsdRws - 278
        OrigWb.Sheets(Rng.Cells(Cnt, 1).Value).Copy after:=NewWb.Sheets(Cnt - 1)
    Next Cnt
'2nd Half of macro that copy and pastes values and saves the file

    Sheets(2).Select
    Range("C264:N273").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C134:N140").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    Dim fname As String
    With ActiveSheet
        fname = .Range("B284").Value
    ActiveWorkbook.SaveAs Filename:= _
        "\\server\folder\folder\2018 Folders & WP\2018 Budget\#Export Files\" & fname, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWindow.Close
    End With


End Sub

 

[gpippin84]

Awesome! Thanks for the help!

I just realized I will have to adjust the second half of the code now since i will have multiple sheets that need the copy paste-value operation performed.

Would you be able to assist in writing this logic?



After I run the piece you have written, I will need to copy and paste-values in some of the copied sheets in the new workbook. I can define that list in cells c279 and below on the original workbook.I'd need to reference those cells to get the sheet names that would need the copy paste-values portion performed. This would only be about 25% of the copied sheets, not all of them. Again the issue would be telling the code to stop once there are no more values. Then moving on to the save portion of the code.

For this section, assume that the sheet with the original referenced cells is not one of the sheets that has been copied to the new workbook. So we probably need to define these before creating the new workbook? Also the area that will be copied and pasted is in the same location on each sheet.

Sheets(SecondSheet).Select
    Range("C264:N273").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C134:N140").Select
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

 

[Fluff]

How about

Sub ExportBranch()

    Dim UsdRws As Integer
    Dim Cnt As Integer
    Dim Rng As Range
    Dim OrigWb As Workbook
    Dim NewWb As Workbook
    Dim NewRng As Range
    Dim Rg As Range
    Dim fname As String

Application.ScreenUpdating = False

    Set OrigWb = ThisWorkbook
    [COLOR=#0000ff]fname = Sheets("####").Range("B284").Text[/COLOR]
    
    With ActiveSheet
        UsdRws = .Range("B279").End(xlDown).Row
        Set Rng = .Range("B279:B" & UsdRws)
        Set NewRng = .Range("C279:C" & .Range("C279").End(xlDown).Row)
    End With

    
    Sheets(Rng.Cells(1, 1).Value).Copy
    Set NewWb = ActiveWorkbook
    For Cnt = 2 To UsdRws - 278
        OrigWb.Sheets(Rng.Cells(Cnt, 1).Value).Copy after:=NewWb.Sheets(Cnt - 1)
    Next Cnt
'2nd Half of macro that copy and pastes values and saves the file

    For Each Rg In NewRng
        With Sheets(Rg.Value)
            .Range("C264:N273").Value = .Range("C264:N273").Value
            .Range("C134:N140").Value = .Range("C134:N140").Value
        End With
    Next Rg
    
    ActiveWorkbook.SaveAs Filename:= _
        "\\server\folder\folder\2018 Folders & WP\2018 Budget\#Export Files\" & fname, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWindow.Close

Application.ScreenUpdating = True

End Sub

You'll need to change where you create fname

 

[gpippin84]

Well let me start by saying thank you. Yes this did work and do everything that I've asked.

However, I am reviewing the new workbook file and where i'm expecting it to be referencing the tabs in the new file, all the formulas are referencing the old workbook.

I think this is because we are not moving a group of files but rather moving them individually. If you look back at my original post, i'm moving them as a group which keeps the references intact.

Any idea how to move the sheets as a group vs 1 by 1? Or another solution that would keep the formulas from referencing the old file?

Thanks,

 

[Fluff]

Ok, try this instead

    Dim UsdRws As Integer
    Dim Cnt As Integer
    Dim Rng As Range
    Dim OrigWb As Workbook
    Dim NewWb As Workbook
    Dim NewRng As Range
    Dim Rg As Range
    Dim fname As String
    Dim Cl As Range
    Dim arr() As Variant
    

Application.ScreenUpdating = False

    Set OrigWb = ThisWorkbook
    fname = Sheets("####").Range("B284").Text
    
    With ActiveSheet
        UsdRws = .Range("B279").End(xlDown).Row
        Set Rng = .Range("B279:B" & UsdRws)
        Set NewRng = .Range("C279:C" & .Range("C279").End(xlDown).Row)
    End With

    For Each Cl In Rng
        Cnt = Cnt + 1
        ReDim Preserve arr(1 To Cnt)
        arr(Cnt) = Cl
    Next Cl
    Sheets(arr).Copy
    
    
'2nd Half of macro that copy and pastes values and saves the file

    For Each Rg In NewRng
        With Sheets(Rg.Value)
            .Range("C264:N273").Value = .Range("C264:N273").Value
            .Range("C134:N140").Value = .Range("C134:N140").Value
        End With
    Next Rg
    
    ActiveWorkbook.SaveAs Filename:= _
        "\\server\folder\folder\2018 Folders & WP\2018 Budget\#Export Files\" & fname, FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    ActiveWindow.Close

Application.ScreenUpdating = True

End Sub

 

[gpippin84]

Thank did it! Thanks you have saved me so much time!

 

[Fluff]

Glad to help & thanks for the feedback