Copy columns to next available row

user_17664038 0
Viewed 34

I am looking to paste the columns from the source worksheet 'Model' to the next available row in the destination worksheet 'summary'. Currently it pastes to row 10 but this will be a repetitive task so it would be good to automate it further. Any help would be much appreciated thanks

Sub MyCopy()   
    Dim myCols As Variant    
    Dim lastRow As Long   
    Dim c As Long    
    
    myCols = Array("W", "J", "D")
    
    For c = LBound(myCols) To UBound(myCols)   

        lastRow = Sheets("Model").Cells(Rows.Count, myCols(c)).End(xlUp).Row

        Sheets("Model").Range(Cells(2, myCols(c)), Cells(lastRow, myCols(c))).Copy   
        Sheets("Summary").Cells(10, c + 1).PasteSpecial Paste:=xlValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False    
    Next c
     Sheets("Summary").Activate
End Sub
paste vba excel
1 Answers

Copy Columns to Another Worksheet

Option Explicit

Sub CopyColumns()
    
    Const sName As String = "Model"
    Const sfRow As Long = 2
    Dim sCols As Variant: sCols = VBA.Array("W", "J", "D")
    
    Const dName As String = "Summary"
    Const dfRow As Long = 10
    Dim dCols As Variant: dCols = VBA.Array("A", "B", "C")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    
    Dim wsrCount As Long: wsrCount = sws.Rows.Count
    Dim nUpper As Long: nUpper = UBound(sCols)
    
    Dim slRow As Long
    Dim dlRow As Long
    Dim n As Long
    Dim r As Long
    
    For n = 0 To nUpper
        r = sws.Cells(wsrCount, sCols(n)).End(xlUp).Row
        If slRow < r Then slRow = r
        r = dws.Cells(wsrCount, dCols(n)).End(xlUp).Row
        If dlRow < r Then dlRow = r
    Next n

    If dlRow < dfRow Then
        dlRow = dfRow
    Else
        dlRow = dlRow + 1
    End If
    
    Dim rCount As Long: rCount = slRow - sfRow + 1
    
    For n = 0 To nUpper
        dws.Cells(dlRow, dCols(n)).Resize(rCount).Value _
            = sws.Cells(sfRow, sCols(n)).Resize(rCount).Value
    Next n
     
    dws.Activate
    
    MsgBox "Columns copied.", vbInformation
    
End Sub
user_98140690
Related