Append workbook with data from another

Question

Hi,

I have a workbook with multiple worksheets. One of the worksheets is a "Master" input sheet that updates the other worksheets in the workbook.

I need a macro that can be applied to a button that copies data from the "Master" sheet, then APPENDS the data to a new workbook, then clears cell contents on the "Master" sheet.

e.g I have data for January on "Master" sheet on workbook 1. Press button to copy & append data to Workbook 2. Clear Cell contents on "Master" sheet.

I then enter February data on "Master" sheet, press button to copy & append workbook 2 then clear cell contents on "Master" sheet.

Result is workbook 2 has data for January AND February.

Any help is greatly appreciated.

Answer 1

Sub CopyWk1ToWk2()

    Dim SWk As Workbook, TWk As Workbook

    Dim SWs As Worksheet, TWs As Worksheet

    Dim TLastRow As Long, SLastRow As Long

    Dim SRng As Range

    Application.DisplayAlerts = False

    Application.ScreenUpdating = False

    Set SWk = Workbooks("Book1.xlsm")

    Set SWs = SWk.Worksheets("Master")

    SLastRow = SWs.Range("A" & Rows.Count).End(xlUp).Row

    If SLastRow = 1 Then Exit Sub

    Set TWk = Workbooks.Open("C:\Test\Book2.xlsx")

    Set TWs = TWk.Worksheets("Sheet1")

    TLastRow = TWs.Range("A" & Rows.Count).End(xlUp).Row

    If TLastRow = 1 Then TLastRow = 0

    Set SRng = SWs.Rows("2:" & SLastRow)

    SRng.Copy TWs.Range("A" & TLastRow + 1)

    SRng.ClearContents

    TWk.Close SaveChanges:=True

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

End Sub

Answer 2

Hi Vijay,

Once again this works fine. Many Thanks.

One more issue I have if you could help with please?

My Master sheet has headers in row 1. Can these headers be kept when the cell contents are cleared & can data from row 2 onwards only be added to the appended workbook 2? (at the moment it's adding the header row)

Many Thanks again.

Answer 3

Set the Path of the file appropriately (look into all bold lines)

Sub CopyWk1ToWk2()

    Dim SWk As Workbook, TWk As Workbook

    Dim SWs As Worksheet, TWs As Worksheet

    Dim TLastRow As Long

Set TWk = Workbooks.Open("C:\Test\Book2.xlsx")

Set SWk = Workbooks("Book1.xlsm")

Set SWs = SWk.Worksheets("Master")

Set TWs = TWk.Worksheets("Sheet1")

    TLastRow = TWs.Range("A" & Rows.Count).End(xlUp).Row

    If TLastRow = 1 Then TLastRow = 0

    Application.ScreenUpdating = False

    SWs.UsedRange.Copy TWs.Range("A" & TLastRow + 1)

    SWs.Cells.ClearContents

    TWk.Close SaveChanges:=True

    Application.ScreenUpdating = True

End Sub

Answer 4

Hi Vijay,

Thanks for your quick reply that works like a dream!.

One thing i notice is that the second workbook has to be open for the macro to work. Is there a away to run the macro with the second workbook closed? i.e run macro, which then opens closed workbook 2, append, save & then close woorkbook 2 with no screen prompts?

Thanks, your assistance is much appreciated!

Answer 5

1. Make a backup of your workbook. 
2. Open your workbook (Book1.xlsm) and ALT+F11
3. Locate your Workbook name in Project Explorer Window
4. Right click on your workbook name > Insert > Module 
5. Copy paste the Macro code given and change the bold lines as per your requirement
6. Go back to your Workbook and ALT+F8 to display Macro Window
7. Run your Macro from here
8. Delete you Macro if the Macro was needed to be run only once.
9. Otherwise save your file as .xlsm if you intend to reuse Macro again.

Note - Your first work has to be saves with .xlsm extension as Macro will be residing here. You need to change bold lines as per your requirements and both workbooks need to be open when running the macro.

'*** Macro Starts

Sub CopyWk1ToWk2()

    Dim SWk As Workbook, TWk As Workbook

    Dim SWs As Worksheet, TWs As Worksheet

    Dim TLastRow As Long

   Set SWk = Workbooks("Book1.xlsm")

Set TWk = Workbooks("Book2.xlsx")

Set SWs = SWk.Worksheets("Master")

Set TWs = TWk.Worksheets("Sheet1")

    TLastRow = TWs.Range("A" & Rows.Count).End(xlUp).Row

    If TLastRow = 1 Then TLastRow = 0

    Application.ScreenUpdating = False

    SWs.UsedRange.Copy TWs.Range("A" & TLastRow + 1)

    SWs.Cells.ClearContents

    Application.ScreenUpdating = True

End Sub