Прекратите стирать содержимое в столбце, не упомянутом в коде

Question

Здравствуйте, я хотел бы создать код, в котором я мог бы скопировать значения в определенном массиве и вставить только значения этого массива в столбец перед. Копируемые массивы находятся в нескольких массивах и должны копироваться и вставляться в передний столбец, но только если в столбце A имеются числовые значения.

Я уже получил очень хороший ответ на этот вопрос от Пола Бика, где код сначала очищает данные из строки перед ее вставкой. Однако, я столкнулся с проблемой, оказывается, что код стирает любой контент, который находится в столбце B: B, то есть столбце, который не должен касаться кода в любом случае.

Чтобы визуализировать это: Вот как выглядят массивы со значениями (желтым) перед копией:

Результат:

Вот код, который я получил от Пола. Он работает почти на 100% правильно, за исключением того, что очищает содержимое в столбце B: B:

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?

Answer 1

Предыдущий ответ очищает содержимое, но для col C (используется константа COL_START - 1)

Вот исправление

---

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

---

до

После

(Дайте мне знать, если вы хотите сохранить все значения в col C)