CODEWITHSUNDEEP
vbaexcel
Alex F
Alex F

Reputation: 2274

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

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.

Upvotes: 2

Views: 515

Answers (5)

M--
M--

Reputation: 28955

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 (i.e. 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 @A.S.H 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)

Upvotes: 1

A.S.H
A.S.H

Reputation: 29332

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

Upvotes: 1

Alex F
Alex F

Reputation: 2274

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

Upvotes: 1

Shai Rado
Shai Rado

Reputation: 33682

Try edited code (I've edited both Subs 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

Upvotes: 1

Doug Coats
Doug Coats

Reputation: 7107

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

Upvotes: 1

Related Questions