首页 文章

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

提问于
浏览 次
0

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

这似乎是问题 - rng1.SpecialCells（xlCellTypeVisible）.Copy Destination：= Sheets（“Combined Totals”） . Range（tCell.Offset（1）＆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
vba

1 回答

  • 0

    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
    回复于

相关问题