Home

Please help me adjust this code to paste into the next blank cell

Mark Hamilton
Occasional Contributor

Hi the following code compares column headers in two sheets and then copies the data from one sheet to the other and into/under the corresponding headers. The problem I having is that when it copies over it overwrites all existing data in the destination sheet. What I would like it to do is to paste into the next available cell at the bottom of all the existing data per column.

 

Sub LookAtColumnHeaders()
    Dim SrcWS        As Worksheet
    Dim TgtWS        As Worksheet
    Dim SrcColHdrs   As Range
    Dim srcCel       As Range
    Dim TgtColHdrs   As Range
    Dim srcLC        As Long
    Dim tgtLC        As Long
    Dim chgCnt       As Long
    Dim newCnt       As Long
    Dim c            As Range
    chgCnt = 0
    newCnt = 0
    Set SrcWS = Sheets("sheet1")
    Set TgtWS = Sheets("sheet2")
    With SrcWS
        'srcLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        srcLC = .Cells(2, Columns.Count).End(xlToLeft).Column
        Set SrcColHdrs = .Range(.Cells(1, "A"), .Cells(1, srcLC))
    End With
    With TgtWS
        'tgtLC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        tgtLC = .Cells(2, Columns.Count).End(xlToLeft).Column
        Set TgtColHdrs = .Range(.Cells(1, "A"), .Cells(1, tgtLC))
    End With
    Application.ScreenUpdating = False
    
    For Each srcCel In SrcColHdrs
        Set c = TgtColHdrs.Find(srcCel.Value, , xlValues, xlWhole, xlByRows, xlNext, False)
        If Not c Is Nothing Then
            chgCnt = chgCnt + 1
            SrcWS.Columns(srcCel.Column).Copy
            TgtWS.Cells(1, c.Column).PasteSpecial
                       
        Else
            newCnt = newCnt + 1
            SrcWS.Columns(srcCel.Column).Copy
            'TgtWS.Cells(1, tgtLC).PasteSpecial
            TgtWS.Cells(1, tgtLC + 1).PasteSpecial
            tgtLC = tgtLC + 1
        End If
    Next srcCel
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox chgCnt & " Quarters were updated" & " and " & newCnt & " Quarters were added"
    
End Sub