Vba 停止删除代码中未提及的列中的内容

嗨，我想创建代码，在那里我可以复制某个数组中的值，并且只将该数组的值粘贴到前面的列中。要复制的数组位于多个数组中，应复制并粘贴到前面的列中，但仅当列a中有数值时

我已经从paul bica那里得到了一个非常好的答案，代码首先从行中清除数据，然后粘贴它。 然而，我遇到了这个问题，结果是代码删除了列B:B中的任何内容，即代码无论如何都不应该触及的列

可视化：这是具有值（黄色）的数组在副本之前的外观：

结果：

这是我从保罗那里得到的密码。除了清除列B:B中的内容外，它几乎100%正确

Option Explicit

Public Sub MoveRowsLeft()

    Const COL_NUMERIC = 1
    Const ROW_START = 4
    Const COL_START = 4

    Dim ws As Worksheet, lr As Long, lc As Long
    Dim nCol As Range, itm As Range, r As Long, arr As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1")

    lr = ws.Cells(ws.Rows.Count, COL_NUMERIC).End(xlUp).Row

    If lr > ROW_START Then
        Application.ScreenUpdating = False
        Set nCol = ws.Range(ws.Cells(ROW_START, COL_NUMERIC), ws.Cells(lr, COL_NUMERIC))
        For Each itm In nCol
            If Not IsError(itm) Then
                If IsNumeric(itm) And Len(itm.Value2) > 0 Then
                    r = itm.Row
                    lc = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
                    If lc > COL_NUMERIC Then
                        arr = ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc))
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)).ClearContents
                        ws.Range(ws.Cells(r, COL_START - 1), ws.Cells(r, lc - 1)) = arr
                    End If
                End If
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

任何知道如何禁止B:B列中的擦除的人？

都会清除内容，但对于

列C

（由常量

列开始-1使用）

这是解决办法



以前


之后


（如果您需要将所有值保留在
列C
）中，请告诉我这可能是罪魁祸首
ws.Range（ws.Cells（r，col\u START），ws.Cells（r，lc））。ClearContents
现在非常完美。我从来没有想过要获得数组的上限-太棒了！再次感谢你。干杯
Option Explicit

Public Sub MoveRowsLeft()
    Const COL_NUMERIC = 1
    Const ROW_START = 4
    Const COL_START = 3
    Dim ws As Worksheet, lr As Long, lc As Long, i As Long
    Dim nCol As Range, itm As Range, r As Long, arr As Variant

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, COL_NUMERIC).End(xlUp).Row
    If lr > ROW_START Then
        Application.ScreenUpdating = False
        Set nCol = ws.Range(ws.Cells(ROW_START, COL_NUMERIC), ws.Cells(lr, COL_NUMERIC))
        For Each itm In nCol
            If Not IsError(itm) Then
                If IsNumeric(itm) And Len(itm.Value2) > 0 Then
                    r = itm.Row
                    lc = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
                    If lc > COL_START Then
                        arr = ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc))
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)).ClearContents
                        For i = IIf(Len(arr(1, 2)) > 0, 2, 3) To UBound(arr, 2)
                            arr(1, i - 1) = arr(1, i)
                        Next
                        arr(1, i - 1) = vbNullString
                        ws.Range(ws.Cells(r, COL_START), ws.Cells(r, lc)) = arr
                    End If
                End If
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub