Trying to copy one worksheet from one workbook into another preexisting worksheet?

Question

I've written the following code which iterates though my worksheets of my main workbook, checks for a conditional, and then if that conditional is satisfied it copies the active worksheet into a new workbook and saves it. However, I would like to just append the worksheet to the other notebook.

Sub Archive_Sheets()

For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    Dim SrchRng As Range, cel As Range
    Set SrchRng = ws.Range("C9:C108")

    Dim bought_amt As Integer
    Dim called_amt As Integer

    bought_amt = 0
    called_amt = 0

    For Each cel In SrchRng
        If InStr(1, cel.Value, "BOUGHT") > 0 Then
            bought_amt = bought_amt + cel.Offset(0, 1).Value
        End If

        If InStr(1, cel.Value, "CALLED") > 0 Then
            called_amt = called_amt + cel.Offset(0, 1).Value
        End If

    Next cel

    If called_amt = bought_amt Then
        ws.Range("A1").Value = "DONE"

        Module8.CopySheet

        Exit For

        'ws.Delete
    End If
Next

End Sub


Sub CopySheet()

    Application.DisplayAlerts = False

    Dim wb_name_arr() As String

    pName = ActiveWorkbook.Path
    wbName = ActiveWorkbook.Name  ' the file name of the currently active file
    shtName = ActiveSheet.Name    ' the name of the currently selected worksheet
    wb_name_arr() = Split(wbName, ".")

    Application.ScreenUpdating = False
    ActiveSheet.Select
    ActiveSheet.Copy
    ' NEED TO CHANGE THIS LINE ********************
    ActiveSheet.SaveAs Filename:=pName + "\" + wb_name_arr(0) + " archived.xlsx"
    '****************************
    Application.ScreenUpdating = True

End Sub

The code above will overwrite the new workbook I'm saving to so it's only the most recent sheet. I will already have this workbook created, so if I can append active worksheets to it that would be ideal. I already tried

ActiveSheet.Copy After:=Workbook(pName + "\" + wb_name_arr(0) + " archived.xlsx")

and

ActiveSheet.Copy Before:=Workbooks.Open(pName + "\" + wb_name_arr(0) + " archived.xlsx").Sheets(0)

with no luck.

Answer 1

Try something like this (to make it simple for the moment, I insert the sheet at beginning):

ActiveSheet.Copy Before:=Workbooks(wb_name_arr(0) & " archived.xlsx").sheets(1)

This works if the destination WB was already open . You may want to open the WB if it is not open yet. Use the following sub to create or open the destination WB:

Sub archiveSheet(ws as Worksheet)
    Dim destName As String
    destName = left(ThisWorkbook.name, InStrRev(ThisWorkbook.name, ".") - 1) & " archived.xlsx"

    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    On Error Resume Next
    Dim destWB As Workbook: Set destWB = Workbooks(destName)
    If destWB Is Nothing Then Set destWB = Workbooks.Open(ThisWorkbook.path + "\" & destName)
    If destWB Is Nothing Then
        Set destWB = Workbooks.Add
        destWB.SaveAs ThisWorkbook.path & "\" & destName
    End If
    If destWB Is Nothing Then
        msgBox "could not open or create " & destName
    Else
        ws.Copy After:=destWB.Sheets(destWB.Sheets.count)
    End If
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
End Sub

Call it from the main routine Archive_Sheets like this:

archiveSheet ws

Answer 2

These line are pseudo-codes. The general idea is Implicit None . Try to explicitly reference to workbooks and sheets instead of activating them. Which is also faster.

Try to avoid using ActiveSheet in your code. Simply try something like this:

Set mySht = ActiveSheet 'This should be set at the beginning of your code

Then whenever you have that Sheet (ie ActiveSheet ) in your code, use oSht instead.

So, you need to open the Workbook to be able to work on it. Similarly, you can assign a name to different workbooks like this:

Set myWbk = ActiveWorkbook
'Or
Set oWbk = Workbooks("Output.xlsx")

What @ASH proposed then works for you like this:

oFile = "Path/to/the/File/" & wb_name_arr(0) & " archived.xlsx"
Set oWbk = Workbooks.Open(oFile)
mySht.Copy Before:=Workbooks(oWbk).sheets(1)

Answer 3

Private Sub that()
    Dim aRR As Variant
    aRR = ThisWorkbook.Sheets("Sheet1").UsedRange
    Dim colC As Long
    Dim rowC As Long

    colC = ThisWorkbook.Sheets("Sheet1").UsedRange.Columns.Count
    rowC = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count

    ThisWorkbook.Sheets("Sheet2").Range(ThisWorkbook.Sheets("Sheet2").Cells(1, 1), ThisWorkbook.Sheets("Sheet2").Cells(rowC, colC)).Value2 = aRR

End Sub

Answer 4

Try edited code (I've edited both Sub s to make them shorter, and also faster as there is no need to use Select and Activate ).

Explanation inside the code as comments.

Option Explicit

Sub Archive_Sheets()

Dim SrchRng As Range, cel As Range
Dim bought_amt As Long
Dim called_amt As Long
Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
    With ws
        Set SrchRng = .Range("C9:C108")
        bought_amt = 0
        called_amt = 0

        For Each cel In SrchRng
            If cel.Value Like "BOUGHT*" Then
                bought_amt = bought_amt + cel.Offset(0, 1).Value
            End If

            If cel.Value Like "CALLED*" Then
                called_amt = called_amt + cel.Offset(0, 1).Value
            End If
        Next cel

        If called_amt = bought_amt Then
            .Range("A1").Value = "DONE"
            CopySheet .Name ' <-- call the function and send the current ws sheet's name

            Exit For
        End If
    End With
Next

End Sub

'==================================================================

Sub CopySheet(wsName As String)

    Application.DisplayAlerts = False

    Dim wb_name_arr() As String
    Dim wb As Workbook
    Dim pName As String, wbName As String

    pName = ActiveWorkbook.Path
    wb_name_arr() = Split(wbName, ".")

    Application.ScreenUpdating = False
    On Error Resume Next
    Set wb = Workbooks(wb_name_arr(0) & " archived.xlsx") ' try to set wb if it's already open
    On Error GoTo 0

    If wb Is Nothing Then ' <-- wb is Nothing, means it's still close, open it
        Set wb = Workbooks.Open(Filename:=pName & "\" & wb_name_arr(0) & " archived.xlsx")
    End If    

    ' === Copy the sheet to "archived" file one before tha last sheet ===
    Worksheets(wsName).Copy before:=wb.Sheets(wb.Sheets.Count)

    Application.ScreenUpdating = True

End Sub

Answer 5

Full code that solves problem.

Sub Archive_Sheets()

For Each ws In ActiveWorkbook.Worksheets
    ws.Activate
    Dim SrchRng As Range, cel As Range
    Set SrchRng = ws.Range("C9:C108")

    Dim bought_amt As Integer
    Dim called_amt As Integer

    bought_amt = 0
    called_amt = 0

    For Each cel In SrchRng
        If InStr(1, cel.Value, "BOUGHT") > 0 Then
            bought_amt = bought_amt + cel.Offset(0, 1).Value
        End If

        If InStr(1, cel.Value, "CALLED") > 0 Then
            called_amt = called_amt + cel.Offset(0, 1).Value
        End If

    Next cel

    If called_amt = bought_amt Then
        If called_amt <> 0 Then
            ws.Range("A1").Value = "DONE"

            Module8.CopySheet

            'ws.Delete
        End If
    End If
Next

End Sub

Sub CopySheet()

    Application.DisplayAlerts = False

    Dim wb_name_arr() As String

    pName = ActiveWorkbook.Path
    wbName = ActiveWorkbook.Name  ' the file name of the currently active file
    shtName = ActiveSheet.Name    ' the name of the currently selected worksheet
    wb_name_arr() = Split(wbName, ".")

    Set mySht = ActiveSheet 'This should be set at the beginning of your code
    Set myWbk = ActiveWorkbook
    oFile = pName & wb_name_arr(0) & " archived.xlsx"
    Set oWbk = Workbooks.Open("path_to_file")
    mySht.Copy after:=oWbk.Sheets(oWbk.Sheets.Count)
    oWbk.Save

End Sub