如何修改此 VBA 以復制和粘貼，但從“B”列開始粘貼？

Question

我為我的書修改了這個被盜用的代碼，但我無法獲得以“B”列開頭的粘貼。 它按原樣工作得很漂亮，從“A”列開始粘貼，但我需要從“B”列開始。

如果工作表 InventoryAvailability 列 U 等於“X”，則復制整行。

代碼：

Sub MoveRowBasedOnCellValueX()

    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("InventoryAvailability").UsedRange.Rows.Count
    J = Worksheets("CountSheet").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("CountSheet").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("InventoryAvailability").Range("U4:U" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "X" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("CountSheet").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    Next
    Application.ScreenUpdating = True
    
End Sub

我嘗試將 Range("A" & Rows.Count) 更改為 Range("B" & Rows.Count)，但沒有任何樂趣。 它運行但沒有任何反應。 我將 Range("B" & Rows.Count) 改回 Range("A" & Rows.Count)，然后從“A”列開始進行復制和粘貼。

請幫助我理解我在做什么和/或理解不正確。

Answer 1

如果您有EntireRow ，則不能偏移粘貼范圍，因為它會脫離工作表。 我已通過將Copy區域更改為僅在使用范圍內來更正此問題。

Option Explicit

Sub MoveRowBasedOnCellValueX()

    Dim xRg As Range
    Dim xCell As Range
    Dim ColWide As Long
    Dim I As Long
    Dim J As Long
    Dim K As Long
    
    I = Worksheets("InventoryAvailability").UsedRange.Rows.Count
    J = Worksheets("CountSheet").UsedRange.Rows.Count
    
    If J = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets("CountSheet").UsedRange) = 0 Then J = 0
    End If
    
    With Worksheets("InventoryAvailability")
        Set xRg = .Range("U4:U" & I)
        ColWide = .UsedRange.Column + .UsedRange.Columns.Count
    
        On Error Resume Next
        
        Application.ScreenUpdating = False
        For K = 1 To xRg.Count
            If CStr(xRg(K).Value) = "X" Then
                .Range("A" & xRg(K).row).Resize(1, ColWide).Copy Destination:=Worksheets("CountSheet").Range("B" & Rows.Count).End(xlUp).Offset(1)
            End If
        Next
        Application.ScreenUpdating = True
    End With
    
End Sub

需要考慮的事項：如果完成此操作所需的時間超過幾秒鍾，您應該考慮將所有數據拉入一個數組，過濾掉不需要的內容，然后將整個數據塊放在目標工作表上。 它會快得多......可能不到一秒鍾。