VBA宏復制和粘貼，粘貼到離散位置

Question

我正在嘗試編寫一個宏，以將信息從一張紙復制並粘貼到另一張紙，具體取決於它是否在原始紙的J列中被標記為“即將完成/完成/正在進行中”（這稱為“跟蹤器”）。 它可以工作-但問題是它正在復制跟蹤器工作表中的整行，而我只希望它復制A：K列。 理想情況下，它將根據狀態將結果發布到Sheet1上的不同位置，但是我總是可以合並另一個宏以隨后執行此操作！ 我必須承認我在使用現有的宏，因為我在VBA上有些虛弱，所以這可能是問題的一部分。 非常感謝。

Sub Copybasedonstatus()
'Niall McCracken 12/12/16

Dim lRow, cRow As Integer        
lRow = Sheets("Tracker").Range("A800").End(xlUp).Row

For j = lRow To 1 Step -1    
    If Sheets("Tracker").Range("J" & j) = "Upcoming" Then
        cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row
        Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

    ElseIf Sheets("Tracker").Range("J" & j) = "Complete" Then
        cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row
        Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

    ElseIf Sheets("Tracker").Range("J" & j) = "In Progress" Then
        cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row
        Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

    End If
Next

End Sub

Answer 1

x一旦您確定要粘貼復制的行（列A：K）的內容（或位置），請告訴我，我可以進行相應的修改。

我使用With Sheets("Tracker")語句使代碼更短（也有助於減少錯誤），我也用Select Case .Range("J" & j).Value替換了If 。

注意 ：如果您不刪除行或單元格，則沒有真正的向后循環的需要。 如果需要，可以使用常規的For j = 1 To lRow 。

碼

Option Explicit

Sub Copybasedonstatus()

'Niall McCracken 12/12/16

Dim lRow As Long, cRow As Long, j As Long

With Sheets("Tracker")
    lRow = .Range("A800").End(xlUp).Row

    ' another method of finding last row in Column A (skipping blank cells in the middle)
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    For j = lRow To 1 Step -1
        cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row

        Select Case .Range("J" & j).Value
            Case "Upcoming"
                .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

            Case "Complete"
                .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

            Case "In Progress"
                .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1)

        End Select
    Next
End With

End Sub