Search code examples
excelvbaif-statementcopy-paste

Move Excel cell data from one column to another via VBA with a condition

I've got text in column B. I'm using a condition that if the text in Column B is "TEST", then I'm moving the existing data in column E&F to columns M&N, respectively and clearing the source cells. It works if my range is small. But when I expand the range, it does not do anything and does not return an error. Is the range to large? I'm basically looking through all of column B which ranges from B2:B15000 but for the case here, I'm only searching through B2:B4000 and it still does nothing. Smaller range like scanning 100 cells works with no issue.

For example, if it finds "TEST" in cells B2, B55 and B56, then this happens to the existing data:

E2 gets moved to M2: E2 contents is cleared: F2 gets moved to N2: F2 contents is cleared:

E55 get moved to M55: E55 contents in cleared: F55 gets moved to N55: F55 contents is cleared:

E56 get moved to M56: E56 contents in cleared: F56 gets moved to N56: F56 contents is cleared:

 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
Solution

  • Copy-Insert Row Ranges

    enter image description here

    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