VBA code to copy specific columns form one workbook to another

Question

So I have two workbooks one is week on week reporting workbook and 2nd one is from where I want to paste the data. So basically I want to copy specific columns from 2nd workbook and paste it into the last row available of the reporting workbook. The reporting workbook has week on week rolling data data should get paste in the last row every time. The code below i have tried but it only copies data to another workbook but not the the last row available of the reporting workbook.

Sub pull_columns()

Dim head_count As Integer
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("Sheet2")

'count headers in this workbook
head_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))

'open other workbook and count rows and columns
Workbooks.Open Filename:="C:\Users\ritwi\Desktop\Book1.xlsm"
ActiveWorkbook.Sheets(1).Activate

row_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
col_count = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))


For i = 1 To head_count

    j = 1
    
    Do While j <= col_count
    
        If ws.Cells(1, i) = ActiveSheet.Cells(1, j).Text Then
        
            ActiveSheet.Range(Cells(1, j), Cells(row_count, j)).Copy
            ws.Cells(1, i).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = col_count
        
        End If
    
    j = j + 1
    
    Loop

Next i

ActiveWorkbook.Close savechanges:=False

ws.Cells(1, 1).Select

Application.ScreenUpdating = True

End Sub

steveP · Answer

One way of doing it. Be sure to update the wb/ws and range references to suit.

Sub AppendData()

Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long

Set wb1 = ThisWorkbook
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set wb2 = Application.Workbooks.Open(ws1.Range("A2").Value)

Application.ScreenUpdating = False

Set wsCopy = wb1.Sheets("Sheet2")
Set wsDest = wb2.Sheets("Sheet1")

'LastRow
 lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row

 'Find first blank row
 lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row

 'Copy & Paste Data
 wsCopy.Range("A2:D" & lCopyLastRow).Copy wsDest.Range("A" & lDestLastRow)

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

VBA code to copy specific columns form one workbook to another

1 Answers