將過濾的範圍複製到第二行，其中列標題匹配

我需要將數據從一個表格複製到另一個表格並粘貼到列標題匹配的下一個可用行中。我無法創建要複製的範圍。將過濾的範圍複製到第二行，其中列標題匹配

這似乎是這個問題 - rng1.SpecialCells（xlCellTypeVisible）.Copy目的地：=表（「資金的總和」）範圍（tCell.Offset（1）& lRow）

我ahve嘗試創建要粘貼到使用單元格和範圍的目標，但我似乎無法正確地將語法添加到語法。我在做什麼錯？

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

來源

2014-03-27 user3432849

'如果不aCell是Nothing Then' - 哪裏是'aCell'而來？ –

對不起我的壞 - 我後來改變了變量名稱。我已經修改了上面的代碼。但這不是問題。 – user3432849

@ user3432849，請考慮關於[接受答案]（http://meta.stackexchange.com/questions/5234/how-does-accepting-an-answer-work/5235#5235） –

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

來源

2014-03-27 04:44:32

謝謝，完美的作品。我應該提到的是，我需要重複這幾個列。（我不能做一個完整的塊範圍，因爲有些表沒有相同的列）。有沒有簡單的方法可以將其他列添加到此過程中，還是需要複製和重新整理整個代碼塊？ – user3432849

將所有列複製到同一行，還是目標列的數據量不同？與您的示例相同的兩張表中的列是否相同？ –

查看我的編輯如何處理多列 –

將過濾的範圍複製到第二行，其中列標題匹配

回答

相關問題