Home

Seach column header, copy data & paste into new sheet PROBLEM

Mark Hamilton
Occasional Contributor

This snippet of code searches for specific headers and then copies the date under them to another sheet. My problem is that it is pasting from Range (A3) and then right. i.e. pasting into cell A3 then B3 then B4 etc. What I need it do is paste under the same header in the other sheet and at the next blank row. Can anyone help with this please?

 

'ThisWorkbook.Worksheets("sheetx").Cells(1, 1).Select
    Worksheets("sheet1").Activate
    a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row

    Dim arrCols, shtSrc As Worksheet, rngDest As Range, hdr, pn

    arrCols = Array("LaboratoryReference", "UniqueCode", "SerialNumber") '<< column headers to be copied

    Set shtsrc=Sheets("Sheet1")              '<< sheet to copy from
    Set rngDest = Sheets("Sheet3").Range("A3") '<< starting point for pasting

    'loop over columns
    For Each hdr In arrCols

        pn = Application.Match(hdr, shtSrc.Rows(1), 0)

        If Not IsError(pn) Then
            '##Edit here##
            shtSrc.Range(shtSrc.Cells(2, pn), _
                         shtSrc.Cells(Rows.Count, pn).End(xlUp)).Copy rngDest
            '/edit
        Else
            rngDest.Value = hdr
            rngDest.Interior.Color = vbRed '<< flag missing column
        End If

        Set rngDest = rngDest.Offset(0, 1)
    Next hdr