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

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 (i.e. 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