copy a filtered range to 2nd row where col headings match

Question

i need to copy data from one sheet to another and paste into the next available row where the column headings match. I am having difficulty creating the range to copy into.

this seems to be the issue - rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Combined Totals").Range(tCell.Offset(1) & lRow)

i ahve tried creating the destination to paste to using Cells and Range, but i can't seem to add variables into the syntax correctly. What am i doing wrong?

Set this to the relevant worksheet
    Set ws = ThisWorkbook.Sheets("OPT 1 Total")

    With ws
        '~~> Find the cell which has the name
        Set sCell = .Range("A1:Z1").Find("MN")
        Set tCell = Sheets("Combined Totals").Range("A1:Z1").Find("MN")


        '~~> If the cell is found
        If Not sCell Is Nothing Then
            '~~> Get the last row in that column and check if the last row is > 1
            lRow = .Range(Split(.Cells(, sCell.Column).Address, "$")(1) & .Rows.Count).End(xlUp).Row

            If lRow > 1 Then
                '~~> Set your Range
                Set rng1 = .Range(sCell.Offset(1), .Cells(lRow, sCell.Column))

               'bCell.Offset(1).Activate
               Debug.Print tCell.Address
               rng1.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("Combined Totals").Range(tCell.Offset(1) & lRow)
               'Cells(2, 1).Resize(rng1.Rows.Count) '



                '~~> This will give you the address
                Debug.Print rng1.Address
            End If
        End If
    End With

sorry my bad - i changed the variable names later. I have amended the code above. That wasn't the problem though. — user3432849

Tim Williams Tim Williams · Accepted Answer · 2014-03-27T04:44:32

EDIT2: parameterized....

Sub CopyAll()

    TransferToTotals "OPT 1 Total", Array("MN", "TX", "CA")
    TransferToTotals "OPT 2 Total", Array("MN", "TX", "CA")

End Sub


Sub TransferToTotals(srcSheet As String, arrHeaders)

Dim ws As Worksheet, sCell As Range, tCell As Range, lstCell As Range
Dim wsd As Worksheet, i As Long, arrHeadings

    Set wsd = ThisWorkbook.Sheets("Combined Totals")
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(srcSheet)
    On Error GoTo 0

    If ws Is Nothing Then
        Debug.Print "Source sheet '" & srcSheet & "' not found!"
        Exit Sub
    End If

    For i = LBound(arrHeaders) To UBound(arrHeaders)
    With ws
        Set sCell = .Range("A1:Z1").Find(arrHeaders(i))
        Set tCell = wsd.Range("A1:Z1").Find(arrHeaders(i))

        If Not sCell Is Nothing And Not tCell Is Nothing Then
            Set lstCell = .Cells(.Rows.Count, sCell.Column).End(xlUp)
            If lstCell.Row > 1 Then

                'EDIT - paste values only...
                .Range(sCell.Offset(1), lstCell).SpecialCells( _
                  xlCellTypeVisible).Copy 
                wsd.Cells(Rows.Count, tCell.Column).End(xlUp) _
                         .Offset(1, 0).PasteSpecial xlPasteValues

            End If
        Else
            Debug.Print "Couldn't find both '" & _
                         arrHeaders(i) & "' headers"
        End If
    End With
    Next i

End Sub

copy a filtered range to 2nd row where col headings match

1 Answers