Question

您好我想创建代码，我可以在其中复制某个数组中的值，并仅将该数组的值粘贴到前面的列中。要复制的数组是多个数组，应该复制并粘贴到前面的列中，但前提是A列中有数值。

我已经从paul bica得到了一个非常好的答案，其中代码首先在粘贴之前清除行中的数据。但是我遇到了这个问题，结果发现代码删除了B列中的任何内容：B，即无论如何都不应被代码触及的列。

使其可视化：这是具有值（黄色）的数组在复制之前的样子：

结果：

这是我从保罗那里得到的代码。除了清除B列中的内容外，它的工作几乎100％正确：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

Previous answer确实清除了内容，但适用于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）

，请告诉我

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

1 个答案: