如何將多個不相鄰的列粘貼到另一個工作表上的最后一個空行上？

Question

我試圖將“聯系計划”工作表中的B，E，I，J列中的過濾后的值（分別由I列過濾以排除空白）粘貼到名為“”的單獨工作表上的B，C，E，L列中CSVControl”。

到目前為止，我已經嘗試了以下代碼，但無法將所有列粘貼到“ CSVControl”中的下一個空行上。 目前，只有B列正確地粘貼在第一個空行中，但是隨后的每個列都在粘貼的前一列的最后一個單元格下方粘貼大約9行（每個副本包含9個條目）。

這是我的代碼：

Sheets("Contact Plans").Select
Range("ContactPlansTable[#All]").Select
ActiveSheet.ListObjects("ContactPlansTable").Range.AutoFilter Field:=8, _
    Criteria1:="<>"

Sheets("Contact Plans").Select
Range(Range("B5"), Range("B5").End(xlDown)).Copy
Sheets("CSVControl").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Sheets("Contact Plans").Select
Range(Range("E5"), Range("E5").End(xlDown)).Copy
Sheets("CSVControl").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Sheets("Contact Plans").Select
Range("I5", Range("I" & Rows.Count).End(xlUp)).Copy
Sheets("CSVControl").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Sheets("Contact Plans").Select
Range("J5", Range("J" & Rows.Count).End(xlUp)).Copy
Sheets("CSVControl").Range("L" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Answer 1

試試這個代碼：

Option Explicit

Public Sub copyColumns()

    Dim wsFrom As Worksheet, wsTo As Worksheet

    With Application.ActiveWorkbook
        Set wsFrom = .Worksheets("Contact Plans")
        Set wsTo = .Worksheets("CSVControl")
    End With
    wsFrom.ListObjects("ContactPlansTable").Range.AutoFilter Field:=8, Criteria1:="<>"

    copyColumn wsFrom, wsTo, "B", "B"
    copyColumn wsFrom, wsTo, "E", "C"
    copyColumn wsFrom, wsTo, "I", "E"
    copyColumn wsFrom, wsTo, "J", "L"
    Application.CutCopyMode = False
    wsTo.Activate
    wsTo.Cells(1, 1).Activate
End Sub

Private Sub copyColumn(ws1 As Worksheet, ws2 As Worksheet, col1 As String, col2 As String)
    Dim vCells As Range
    Set vCells = ws1.Range(col1 & "5:" & col1 & ws1.Range(col1 & "5").End(xlDown).Row)
    vCells.SpecialCells(xlCellTypeVisible).Copy
    ws2.Columns(col2).End(xlDown).Offset(1).PasteSpecial xlPasteValues
End Sub

行偏移量無法按預期工作，因為每次復制/粘貼操作后Rows.Count都會增加