VBA to Reorganize Column

[edk3742]

Hi All.

VBA newbie here with experience in MatLab so there is vague familiarity with syntax and the logic operators (if, while, for, etc.)

So I have a column of data points with blank cells scattered about. I have used http://www.cpearson.com/Excel/NoBlanks.aspx to convert the column into an array without any empty cells. The next problem I have is inputting blank cells between differing grid points. I would like to input an empty cell wherever Left(Cell-1,1) is not equal to Left(cell,1) (basically whenever the first character in a string of a column vector is different from previous row). This is the function used:

Function NoBlanks(RR As Range) As Variant
Dim Arr() As Variant
Dim R As Range
Dim N As Long
Dim L As Long
If RR.Rows.Count > 1 And RR.Columns.Count > 1 Then
NoBlanks = CVErr(xlErrRef)
Exit Function
End If

If Application.Caller.Cells.Count > RR.Cells.Count Then
N = Application.Caller.Cells.Count
Else
N = RR.Cells.Count
End If

ReDim Arr(1 To N)
N = 0
For Each R In RR.Cells
If Len(R.Value) > 0 Then
N = N + 1
Arr(N) = R.Value
End If
Next R
For L = N + 1 To UBound(Arr)
Arr(L) = vbNullString
Next L
ReDim Preserve Arr(1 To L)
If Application.Caller.Rows.Count > 1 Then
NoBlanks = Application.Transpose(Arr)
Else
NoBlanks = Arr
End If
End Function

If anyone has any insight in how to go about achieving this I would be very thankful.

 

[Rijnsent]

Hi edk,
so you basically want to change that function to output an array that has a blank cell between two rows that have a different starting character? E.g. if your data would be:
bla - empty - empty - bla - empty - empty - test - empty -empty - test -> bla -bla -empty - test -test ?
If so, this could help (quick & dirty, hardly tested it):

Function NoBlanks(RR As Range) As Variant
    Dim Arr() As Variant
    Dim Arr2() As Variant
    Dim R As Range
    Dim N As Long
    Dim L As Long
    If RR.Rows.Count > 1 And RR.Columns.Count > 1 Then
        NoBlanks = CVErr(xlErrRef)
        Exit Function
    End If
    
    If Application.Caller.Cells.Count > RR.Cells.Count Then
        N = Application.Caller.Cells.Count
    Else
        N = RR.Cells.Count
    End If
    
    ReDim Arr(1 To N)
    N = 0
    For Each R In RR.Cells
        If Len(R.Value) > 0 Then
            N = N + 1
            Arr(N) = R.Value
        End If
    Next R
    For L = N + 1 To UBound(Arr)
        Arr(L) = vbNullString
    Next L
    ReDim Preserve Arr(1 To L)
    'Add extra empty rows
    B = 0
    ReDim Arr2(1 To L)
    For A = 1 To L
        If A = 1 Then
            Arr2(A + B) = Arr(A)
        Else
            If Left(Arr(A), 1) <> Left(Arr(A - 1), 1) Then
                ReDim Preserve Arr2(1 To UBound(Arr2) + 1)
                Arr2(A + B) = vbNullString
                B = B + 1
            End If
            Arr2(A + B) = Arr(A)
        End If
    Next A
    
    If Application.Caller.Rows.Count > 1 Then
        NoBlanks = Application.Transpose(Arr2)
    Else
        NoBlanks = Arr2
    End If
End Function

And for a good start with VBA, try e.g. http://homeandlearn.org/ or https://www.excel-pratique.com/en/vba.php
Cheers,
Koen