Append Data to Bottom When Using Combine & Merge Macro

[wealthistime]

Hello,

I am using the below code to combine workbooks into a single sheet. The macro works perfectly for combinging the sheets, however, I can only run the code once. If I run the macro a second time, the data from the first run is overwritten. I would like it to be such that you can run the macro over and over again, and each set of new data will be appended to the next empty row. Unfortunately, I just haven't been able to get this to work. Any help is appreciated. Thanks!

A Sample of the destination workbook ("Invoice Workbook") and the source data ("TSR Template1-Test1") are in the attached zip.

Sub Consolidate()
' This macro imports (combines) all TSR workbooks into one sheet.

' This defines various objects
    Dim fName As String, fPath As String, fPathDone As String, OldDir As String
    Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet
    Dim LR As Long, NR As Long

' This speeds up the macro.
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
            
' This defines that the current workbook is the detination for all the TSR workbooks to be copied too.
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Invoice Data").Activate
    ActiveSheet.Unprotect
        
' This defines the range of each TSR workbook to be copied.
    NR = Range("A8:BP27").End(xlUp).Row + 1

' This sets the path of the folder where the TSR workbooks to be imported are stored.
    OldDir = CurDir
    With Application.FileDialog(msoFileDialogFolderPicker)
' The default path is the F drive
        .InitialFileName = ("F:\")
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    ChDir fPath
    fName = Dir("*.xl*")

' This imports the first sheet from each TSR workbook in the folder.
    Do While Len(fName) > 0
    Set wbkOld = Workbooks.Open(fName)
    Sheets(1).Activate
' This imports only rows where column BO is not blank.
    LR = Range("BO" & Rows.Count).End(xlUp).Row
' This copies only the given range of data from each TSR.
    Range("A8:BP27").Copy
' This pastes values in column A of the destination workbook.
    wbkNew.Sheets("Invoice Data").Range("A" & NR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                
' This closes the TSR workbooks and moves on to the next TSR workbook and the next empty row in the destination workbook.
    wbkOld.Close False
    NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    fName = Dir
    Loop

' This clears data in entire rows where Column A (AFG#) is blank.
    Dim myColm As Range
    Set myColm = Columns("A:A")
    On Error Resume Next
    myColm.SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
    Range("A1").Select
    
' This restores the original working path.
    ChDir OldDir
    
' This reprotects the sheet.
    Sheets("Invoice Data").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True, AllowUsingPivotTables:= _
        True
    
' This resets the settings we changed to speed up the macro.
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic


    
End Sub

[pike]

wealthistime,
with your code you need to move the row counter inside the loop

' This pastes values in column A of the destination workbook.
  NR = wbkNew.Sheets("Invoice Data").Range("A8:BP27").End(xlUp).Row + 1
   wbkNew.Sheets("Invoice Data").Range("A" & NR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

[wealthistime]

Hi Pike,
Sorry but I can't seem to make the adjustment. I modified the code but now i only get five rows. When I go through it, it's copying Range A:BO and pasting it over the same range.

In short, my code is not going to the next blank row. Any ideas? here is the modified code:

 Sub Consolidate()
' This macro imports (combines) all TSR workbooks into one sheet.

' This defines various objects
    Dim fName As String, fPath As String, fPathDone As String, OldDir As String
    Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet
    Dim LR As Long, NR As Long

' This speeds up the macro.
    Application.ScreenUpdating = True
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
            
' This defines that the current workbook is the detination for all the TSR workbooks to be copied too.
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Invoice Data").Activate
    ActiveSheet.Unprotect
        
' This sets the path of the folder where the TSR workbooks to be imported are stored.
    OldDir = CurDir
    With Application.FileDialog(msoFileDialogFolderPicker)
' The default path is the F drive
        .InitialFileName = ("F:\")
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    ChDir fPath
    fName = Dir("*.xl*")

' This imports the first sheet from each TSR workbook in the folder.
    Do While Len(fName) > 0
    Set wbkOld = Workbooks.Open(fName)
    Sheets(1).Activate
' This imports only rows where column BO is not blank.
    LR = Range("BO" & Rows.Count).End(xlUp).Row
' This copies only the given range of data from each TSR.
    Range("A8:BP27").Copy
' This pastes values in column A of the destination workbook.
    NR = wbkNew.Sheets("Invoice Data").Range("A8:BP27").End(xlUp).Row + 1
    wbkNew.Sheets("Invoice Data").Range("A" & NR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                
' This closes the TSR workbooks and moves on to the next TSR workbook and the next empty row in the destination workbook.
    wbkOld.Close False
    fName = Dir
    Loop

' This clears data in entire rows where Column A (AFG#) is blank.
    Dim myColm As Range
    Set myColm = Columns("A:A")
    On Error Resume Next
    myColm.SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
    Range("A1").Select
    
' This restores the original working path.
    ChDir OldDir
    
' This reprotects the sheet.
    Sheets("Invoice Data").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True, AllowUsingPivotTables:= _
        True
    
' This resets the settings we changed to speed up the macro.
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic

[pike]

replace

' This copies only the given range of data from each TSR.
    Range("A8:BP27").Copy
' This pastes values in column A of the destination workbook.
    NR = wbkNew.Sheets("Invoice Data").Range("A8:BP27").End(xlUp).Row + 1
    wbkNew.Sheets("Invoice Data").Range("A" & NR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

with

 Range("A8:BP27").Copy Destination:=wbkNew.Sheets("Invoice Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

[wealthistime]

How do I get the code you provided to do a paste value instead of a paste? This step is necessary upon each iteration. If I can get it to paste value then it will be perfect! Thanks so much for your help thus far!

[pike]

Hi wealthistime
try...

 LR =Cells(Rows.Count, 1).End(xlUp).Row
 
if LR >8 then
Range("A8:BP" &  LR ).Copy Destination:=wbkNew.Sheets("Invoice Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
end if

[wealthistime]

I'm afraid that doesn't work at all. The code you provided before (below) works perfectly...except i need to do a paste value and not a paste...:

Range("A8:BP27").Copy Destination:=wbkNew.Sheets("Invoice Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

[pike]

untested but try

Range("A8:BP27").Copy 
wbkNew.Sheets("Invoice Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

[wealthistime]

Woo hoo! That did the trick allright. I had tried something similar but didnt have it correctly written. Thanks so much! this will be a huge help. I wll post final code when i have some other tweaks perfected. Thank you!

[pike]

If you are satisfied with the solution(s) provided, please mark your thread as Solved.

How to mark a thread Solved
Go to the first post
Click edit
Click Go Advanced
Just below the word Title you will see a dropdown with the word No prefix.
Change to Solved
Click Save

can you please add a location to your profile so we know what time zone you are in

[wealthistime]

FINAL CODE:

Sub Consolidate()
' This macro imports (combines) all TSR workbooks into one sheet.

' This defines various objects
    Dim fName As String, fPath As String, fPathDone As String, OldDir As String
    Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet

' This speeds up the macro.
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
            
' This defines that the current workbook is the detination for all the TSR workbooks to be copied too.
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Invoice Data").Activate
    ActiveSheet.Unprotect
        
' This sets the path of the folder where the TSR workbooks to be imported are stored.
    OldDir = CurDir
    With Application.FileDialog(msoFileDialogFolderPicker)
' The default path is the F drive.
        .InitialFileName = ("F:\")
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    ChDir fPath
    fName = Dir("*.xl*")

' This imports the first sheet from each TSR workbook in the folder.
    Do While Len(fName) > 0
    Set wbkOld = Workbooks.Open(fName)
    Sheets(1).Activate
    
' This copies only the given range of data from each TSR.
    Range("A8:BP27").Copy
    wbkNew.Sheets("Invoice Data").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                
' This closes the TSR workbooks and moves on to the next TSR workbook and the next empty row in the destination workbook.
    wbkOld.Close False
    fName = Dir
    Loop
    
' This restores the original working path.
    ChDir OldDir

' This clears data in where Column A (AFG#) is blank.
    Sheets("Invoice Data").Activate
    Range("A6:A10000").SpecialCells(xlCellTypeBlanks).Columns("A:BP").ClearContents
    Range("A1").Select
    
' This reprotects the sheet.
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True, AllowUsingPivotTables:= _
        True
    
' This resets the settings we changed to speed up the macro.
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
   
End Sub