Question

我需要将数据从一个工作表复制到另一个工作表并粘贴到列标题匹配的下一个可用行。我无法创建要复制到的范围。

这似乎是个问题 - rng1.SpecialCells（xlCellTypeVisible）.Copy Destination：= Sheets（“Combined Totals”）。Range（tCell.Offset（1）＆amp; lRow）

我尝试使用单元格和范围创建要粘贴的目标，但我似乎无法正确地将变量添加到语法中。我做错了什么？

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

Answer 1

EDIT2 ：参数化....

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

将过滤范围复制到col标题匹配的第2行

1 个答案: