Variable searching cells VBA

Question

I have the following column (1):

1
15
150
   1500000
      06700
      07290
      07500
2
22
220
   2200000
      00900

This would need to become 2 columns

1   
15  
150 
1500000       06700
1500000       07290
1500000       07500
2   
22  
220    
2200000       00900

My initial idea:

• Create the extra column.
• Looping through the rows, register the cell and value in variables when a number with lenght of 7 digits is found.
• Move the values under it to column B until the lenght of values is <> 5
• Start from cell saved in variable and copy value from variable to column A until column A is no longer Empty
• After the above proces, loop rows and delete where A is lenght 7 and B is empty.

As i am not familiar with VBA, before i plunge into, i would like to verify this above set of rules would do what i intend it to do, if it's technically feasable with VBA macro's and wether or not it could result to unexpected behaviour.

This code would have to run every month on a new large excel file.

Answer 1

Whether your 5 digit (c/w/ leading zeroes) numbers are true numbers with a cell formatting of 00000 or text-that-look-like-numbers with a Range.PrefixCharacter property, the Range.Text property should be able to determine their trimmed length from the displayed text.

The following code follows your logic steps with a few modifications; the most obvious one is that it walks from the bottom of column A to the top. This is to avoid skipping rows that have been deleted.

Sub bringOver()
    Dim rw As Long, v As Long, vVAL5s As Variant, vREV5s As Variant

    'put the cursor anywhere in here and start tapping F8
    'it will help if you can also see the worksheet with your
    'sample data

    ReDim vVAL5s(0) 'preset some space for the first value

    With Worksheets("Sheet1")   '<~~ set this worksheet reference properly!
        'ensure a blank column B
        .Columns(2).Insert

        'work from the bottom to the top when deleting rows
        'or you risk skipping a row
        For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            'determine the length of the trimmed displayed length
            'and act accordingly
            Select Case Len(Trim(.Cells(rw, 1).Text))
                Case Is < 5
                    'do nothing
                Case 5
                    'it's one to be transferred; collect it
                    vVAL5s(UBound(vVAL5s)) = .Cells(rw, 1).Text
                    'make room for the next
                    ReDim Preserve vVAL5s(UBound(vVAL5s) + 1)
                Case 7
                    'only process the transfer if there is something to transfer
                    If CBool(UBound(vVAL5s)) Then
                        'the array was built from the bottom to the top
                        'so reverse the order in the array
                        ReDim vREV5s(UBound(vVAL5s) - 1)
                        For v = UBound(vVAL5s) - 1 To LBound(vVAL5s) Step -1
                            vREV5s(UBound(vREV5s) - v) = vVAL5s(v)
                        Next v
                        'working With Cells is like selecting htem but without selecting them
                        'want to work With a group of cells tall enough for all the collected values
                        With .Cells(rw, 1).Resize(UBound(vREV5s) + 1, 1)
                            'move over to column B and put the values in
                            .Offset(0, 1) = Application.Transpose(vREV5s)
                            'make sure they show leading zeroes
                            .Offset(0, 1).NumberFormat = "[Color13]00000;[Color9]@"
                            'if there was more than 1 moved over, FillDown the 7-wide value
                            If CBool(UBound(vREV5s)) Then .FillDown
                            'delete the last row
                            .Cells(.Rows.Count + 1, 1).EntireRow.Delete
                        End With
                        'reset the array for the next first value
                        ReDim vVAL5s(0)
                    End If
                Case Else
                    'do nothing
            End Select
            'move to the next row up and continue
        Next rw
        'covert the formatted numbers to text
        Call makeText(.Columns(2))
    End With
End Sub

Sub makeText(rng As Range)
    Dim tCell As Range
    For Each tCell In rng.SpecialCells(xlCellTypeConstants, xlNumbers)
        tCell.Value = Format(tCell.Value2, "\'00000;@")
    Next tCell
End Sub

Just before exiting the primary routine, the short helper sub is called using column B as a range of cells. This will loop through all of the numbers in column B and convert the numbers into text with leading zeroes.

As noted in the code comments, set yourself up so you can see the code sheet as well as a portion of your worksheet and start tapping F8 to step through the code. I've tried to add a form of running commentary with the notes left above many of the code lines.

Answer 2

After writing the logic keeping in mind Jeeped's input i ended up making it the following way:

• Force convert the column A to definately be Text
• Create the extra column.
• Get the number of rows with data
• Loop 1: If column A cell lenght is 5, move cell to column B
• Loop 2: If column A cell lenght is 7, we copy the value to variable.
• Loop 2: If column A cell lenght is 0, we paste variable to the cell
• After the above proces, loop rows and delete where A is lenght 7 and B is empty. (reverse loop for performance)

All input on the below posted code is more than welcome. I'm open for every kind of possible optimization.

    Sub FixCols()

    'First trim the numbers (text) with 2 methods. VBA trim and Worksheet formula trim
        Range("A:A").NumberFormat = "@"

        Dim Cell As Range
        For Each Cell In ActiveSheet.UsedRange.Columns("A").Cells
          x = x + 1
          Cell = Trim(Cell)
          Cell.Value = WorksheetFunction.Trim(Cell.Value)
        Next

    'Now insert empty column as B
        Columns("B:B").Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    'Determine rows with values for loop
        With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With

    'Loops to move around the data

    Dim i As Long
    Dim CellValue As Long

        For i = 1 To LastRow
        'move items to column B
            If Len(Range("A" & i).Value) = 5 Then
                Range("A" & i).Select
                Selection.Cut
                Range("B" & i).Select
                ActiveSheet.Paste
            End If
        Next i

        For i = 1 To LastRow
            'if the row is a reknr we copy the value
            If Len(Range("A" & i).Value) = 7 Then
                CellValue = Range("A" & i).Value
            End If
            'Paste the reknr to the rows with item
            If Len(Range("A" & i).Value) = 0 Then
                Range("A" & i).Value = CellValue
            End If
        Next i

    'Reverse loop (performance) to check for rows to delete (reknr without item)
        i = LastRow
        Do
            If Len(Range("A" & i).Value) = 7 And Len(Range("B" & i).Value) = 0 Then
                Rows(i).Delete
            End If
            i = i - 1
        Loop While Not i < 1

    End Sub