通过 VBA 使用条件将 Excel 单元格数据从一列移动到另一列

Question

我在 B 列中有文本。我使用的条件是，如果 B 列中的文本是“TEST”，那么我将 E 列和 F 列中的现有数据分别移动到 M 列和 N 列，并清除源单元格。如果我的范围很小，它会起作用。但是当我扩大范围时，它不会执行任何操作，也不会返回错误。范围大吗？我基本上浏览了 B2:B15000 范围内的所有 B 列，但对于这里的情况，我只搜索 B2:B4000，但它仍然什么也不做。扫描 100 个细胞等较小范围是没有问题的。

例如，如果在单元格 B2、B55 和 B56 中找到“TEST”，则现有数据会发生这种情况：

E2 移动到 M2： E2内容被清除： F2 移至 N2： F2内容清空：

E55 移至 M55： 清除后的E55内容： F55 移至 N55： F55内容被清除：

E56 移至 M56： 清除后的E56内容： F56 移至 N56： F56内容被清除：

 Sub MoveIt2()

 If Range("B2:B4000").Cells(i, 1).Value = "TEST" Then

 With ActiveSheet
     .Range("E2:E4000").Copy
     .Range("M2:M4000").Insert Shift:=xlToRight
     .Range("E2:E4000").ClearContents
     .Range("F2:F4000").Copy
     .Range("N2:N4000").Insert Shift:=xlToRight
     .Range("F2:F4000").ClearContents
 

End With

End If

Application.CutCopyMode = False

End Sub

Answer 1

复制插入行范围

Sub MoveIt2()
    
    ' Define constants.
    
    Const SRC_LOOKUP_FIRST_CELL As String = "B2"
    Const SRC_COPY_COLUMNS As String = "E:F"
    Const DST_INSERT_COLUMN As String = "M"
    Const LOOKUP_STRING As String = "Test"
    
    ' Reference the worksheet.
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
     
    ' Reference the source lookup range.
     
    Dim slrg As Range:
    
    With ws.Range(SRC_LOOKUP_FIRST_CELL)
        Set slrg = ws.Range(.Cells, ws.Cells(ws.Rows.Count, .Column).End(xlUp))
    End With
    
    ' Reference the source copy range.
    
    Dim scrg As Range: Set scrg = slrg.EntireRow.Columns(SRC_COPY_COLUMNS)
    
    ' Combine each copy-row into the source union range.
    
    Dim surg As Range, cell As Range, r As Long, CellString As String
    
    For Each cell In slrg.Cells
        r = r + 1
        CellString = CStr(cell.Value)
        If StrComp(CellString, LOOKUP_STRING, vbTextCompare) = 0 Then ' is equal
            If surg Is Nothing Then ' first
                Set surg = scrg.Rows(r)
            Else ' all but first
                Set surg = Union(surg, scrg.Rows(r))
            End If
        'Else ' is not equal; do nothing
        End If
    Next cell
    
    If surg Is Nothing Then Exit Sub
    
    ' Using the column offset, reference the destination union range.
    
    Dim ColumnOffset As Long:
    ColumnOffset = ws.Columns(DST_INSERT_COLUMN).Column - scrg.Column
    
    Dim durg As Range: Set durg = surg.Offset(, ColumnOffset)
    
    ' Insert.
    
    Application.ScreenUpdating = False
    
    durg.Insert Shift:=xlToRight
    
    ' Copy the source union rows to the destination union rows.
    
    Dim sarg As Range
    
    For Each sarg In surg.Areas
        ' Copy values only (fast).
        sarg.Offset(, ColumnOffset).Value = sarg.Value
        ' Copy formulas and formats (slow).
        'sarg.Copy sarg.Offset(, ColumnOffset)
    Next sarg
    
    ' Clear the contents in the source union range.
    
    surg.ClearContents
    
    Application.ScreenUpdating = True
    
    ' Inform.

    MsgBox "MoveIt2 has finished.", vbInformation

End Sub