VBA Macro Move Cells to top of next column based on criteria

Question

I have some spreadsheet data that will be in multiples columns but the number of columns will vary from 1 to 8 based on the number of entries. I have some entries that start with the same 2 characters in this format: CF 12456 There could be only 1 of these or many of these "CF 12345"s Once the data is spread out into evenly distributed columns, I need to move all the cells with a "CF 12345" into a new column that will be the last column of data (ie if there are 6 columns of data, the "CF 12345" column should be to the right of column 6). This code does all of that except it moves all the "CF 12345"s to column I (yes, I know its because that is what the code is telling it to do). Here is the code:

Sub DiscrepancyReportMacroStepTwo()

    'Step 4: Find CF cells move to the top of their own column
    Dim rngA As Range
    Dim cell As Range

    Set rngA = Sheets("Sheet1").Range("A2:H500")
    For Each cell In rngA
        If cell.Value Like "*CF*" Then
            cell.Copy cell.Offset(0, 1)
            cell.Clear
        End If
    Next cell
End Sub

Answer 1

Iterate on the columns of the used range and for each found cell matching the pattern, swap its value with the top cell. If you need to keep all the cell values, you need to track the current top row where you need to swap.

By the way, your pattern seems to be "CF *" , not "*CF*" , unless you made a mistake in the problem description. This code will move all your CF * cells to the top while preserving all values existing in the worksheet.

Sub DiscrepancyReportMacroStepTwo()
  Dim cel As Range, col As Range, curRow As Long, temp
  For Each col In Sheets("Sheet1").UsedRange.Columns
    curRow = 1
    For Each cel In col.Cells
      If cel.Value2 Like "CF *" Then
        ' Swap values of the cell and a cel from top of the column (at curRow)
        temp = col.Cells(curRow).Value2
        col.Cells(curRow).Value2 = cel.Value2
        cel.Value2 = temp
        curRow = curRow + 1
      End If
    Next cel
  Next col
End Sub

EDIT

The above code moves the CF * cells to the top of the column. To add them in a new separate column, use this:

Sub DiscrepancyReportMacroStepTwo()
  Dim lastColumn As Long, lastRow As Long, cel As Range, curRow As Long
  With Sheets("Sheet1")
    lastColumn = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
    lastRow = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).row

    For Each cel In .Range("A2", .Cells(lastRow, lastColumn))
      If cel.Value2 Like "CF *" Then
        curRow = curRow + 1
        .Cells(curRow, lastColumn + 1).Value2 = cel.Value2
        cel.Clear
      End If
    Next cel
  End With
End Sub

Answer 2

You can use a regular expression to look for the 'CF *' values which will ensure that you select only values that start with 'CF ' followed by 5 digits as per your problem statement. If you don't know the # of digits but know it'll be between 2 and 5 digits, you can change the regular expression pattern to: "^CF [\\d]{2,5}$"

Option Explicit

Sub Move2LastCol()
  Dim sht As Worksheet
  Set sht = Worksheets("Sheet1")

  Dim regEx As Object
  Set regEx = CreateObject("vbscript.regexp")
  regEx.Pattern = "^CF [\d]{5}$"

  Dim r As Integer, c As Integer, lastRow As Integer, lastCol As Integer
  Dim tmp As String
  With sht
    lastCol = .Cells.Find(What:="*", SearchOrder:=xlColumns, _
              SearchDirection:=xlPrevious, LookIn:=xlValues).Column + 1
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    For r = 1 To lastRow:
      Dim c1 As Integer: c1 = lastCol
      For c = 1 To .Cells(r, lastCol).End(xlToLeft).Column:
       If regEx.Test(.Cells(r, c)) Then
          tmp = .Cells(r, c).Value2
          .Cells(r, c).Clear
          .Cells(r, c1).Value2 = tmp
          c1 = c1 + 1
          Exit For
       End If
      Next
    Next

  End With

End Sub