groups column A into categories based on first few characters (VBA)

[Lenna]

I have been working on a routine that groups column A into categories based on the few first characters of each string. Column A contains up to six of these categories sorted alphabetically: “A*”, “B*”, “C*”, “DQB*”, “DRB1*” and “DRB*".

This is what I'm trying to achieve:

Header				A	B	C	DQB	DRB1	DRB
A3456				A3456
B4356					B4356
C7890						C7890
C9876						C9876
DQB3456							DQB3456
DRB12234								DRB12234
DRB13456								DRB13456
DRB13456								DRB13456
DRB2345									DRB2345
DRB9876									DRB9876

<tbody>
</tbody>

Column A is copied into six columns. If the specific search string is not found in each column, the data is deleted down and to the right. The code below works most of the time but sometimes fails to identify the correct column. Please suggest how to improve the code so it always works. I would like to know if there is a better way of accomplishing the same thing. I've spent a lot of time on this code and still can't get it to work 100%.

Thank you,

Please see the code:

Sub FilterData()




   Dim FirstRow As Integer
    Dim SecondRow As Integer
    Dim ThirdRow As Integer
    Dim FourthRow As Integer
    Dim FifthRow As Integer
    
    Application.ScreenUpdating = False
    
   
    cutoff = 1000
    
    Range("A2", [A2].End(xlDown)).Copy Range("E2:J2")
    ActiveSheet.Range("$A$1:$B$1").Autofilter Field:=2, Criteria1:=">=" & cutoff
    
    'Else
    
    'MsgBox "Cutoff not defined. Please Clear the Calculator, select the cutoff and select your test(s) again", , "Missing Cutoff Filter"
    
    'Call ClearFilter
    
    'Exit Sub
    'End If
    
    
    FirstRow = 2
    Range("E2").Select
    If Left(ActiveCell, 1) = "A" Then
        Do Until Left(ActiveCell, 1) <> "A" And ActiveCell.Rows.Hidden = False
            FirstRow = ActiveCell.Row
            ActiveCell.Offset(1, 0).Select
        Loop
        Range(ActiveCell.Address, ActiveCell.End(xlDown)).ClearContents
        Range("F2:J" & FirstRow).ClearContents
        Range("F" & FirstRow + 1).Select
        
    Else
        Range(ActiveCell.Address, ActiveCell.End(xlDown).Address).ClearContents
        Range("F" & FirstRow).Select


    End If
    
    SecondRow = FirstRow
    If Left(ActiveCell, 1) = "B" Then
        
        Range("G2:J" & FirstRow).ClearContents  'added to clear contents when prior starting value not found
        
        Do Until Left(ActiveCell, 1) <> "B" And ActiveCell.Rows.Hidden = False
            SecondRow = ActiveCell.Row
            ActiveCell.Offset(1, 0).Select
        Loop
        Range(ActiveCell.Address, ActiveCell.End(xlDown)).ClearContents
        Range("G" & FirstRow + 1, "J" & SecondRow).ClearContents
        Range("G" & SecondRow + 1).Select
        
    Else
        Range(ActiveCell.Address, ActiveCell.End(xlDown).Address).ClearContents
        Range("G" & SecondRow).Select


    End If
    
    ThirdRow = SecondRow
    If Left(ActiveCell, 1) = "C" Then
    
        Range("H2:J" & SecondRow).ClearContents  'added to clear contents when prior starting value(s) not found
    
        Do Until Left(ActiveCell, 1) <> "C" And ActiveCell.Rows.Hidden = False
            ThirdRow = ActiveCell.Row
            ActiveCell.Offset(1, 0).Select
        Loop
        Range(ActiveCell.Address, ActiveCell.End(xlDown)).ClearContents
        Range("H" & SecondRow + 1, "J" & ThirdRow).ClearContents
        Range("H" & ThirdRow + 1).Select
        
    Else
        Range(ActiveCell.Address, ActiveCell.End(xlDown).Address).ClearContents
        Range("H" & ThirdRow).Select
        
    End If
    
    FourthRow = ThirdRow
    If Left(ActiveCell, 2) = "DQ" Then


        Range("I2:J" & ThirdRow).ClearContents  'added to clear contents when prior starting value(s) not found


        Do Until Left(ActiveCell, 3) <> "DQB" And ActiveCell.Rows.Hidden = False
            FourthRow = ActiveCell.Row
            ActiveCell.Offset(1, 0).Select
        Loop
        Range(ActiveCell.Address, ActiveCell.End(xlDown)).ClearContents
        Range("I" & ThirdRow + 1, "J" & FourthRow).ClearContents
        Range("I" & FourthRow + 1).Select
        
    Else
        Range(ActiveCell.Address, ActiveCell.End(xlDown).Address).ClearContents
        Range("I" & FourthRow).Select
        
    End If
    
    FifthRow = FourthRow
    If Left(ActiveCell, 4) = "DRB1" Then


        Range("J2:J" & FourthRow).ClearContents  'added to clear contents when prior starting value(s) not found


        Do Until Left(ActiveCell, 4) <> "DRB1" And ActiveCell.Rows.Hidden = False
            FifthRow = ActiveCell.Row
            ActiveCell.Offset(1, 0).Select
        Loop
        Range(ActiveCell.Address, ActiveCell.End(xlDown)).ClearContents
        Range("J" & FourthRow + 1, "J" & FifthRow).ClearContents
        
        Else
        Range(ActiveCell.Address, ActiveCell.End(xlDown).Address).ClearContents
        
    End If

 

[JLGWhiz]

Maybe something like this. You would have to build an array to define your break points in the data, similar to your illustration but a little more finite. If you have the data sorted, it should be easy enough to pick the characters which you want to use for flags, like DQB1, DQB2, DRB1, DRB2, etc. This code uses the inStr method to see if that flag is the first position of the string and if it is, then it will enter a header for the inserted column and list each item that matches the flag in column E, the it inserts another column E and shifts the completed column to the right. The array lists the flag characters in reverse order because the code works from the bottom of the sheet upward. When it completes, it cascades downward from left to right in ascending order as shown in your illustration. You will probably need to doctor the array to your specific needs, but the rest of the code should work as is.

Sub cascade()
Dim sh As Worksheet, lr As Long, ary As Variant
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
ary = Array("DRB1", "DRB0", "DQB", "C", "B", "A")
    x = lr
    For i = LBound(ary) To UBound(ary)
        sh.Columns(5).Insert xlShiftToRight
        sh.Cells(1, 5) = ary(i)
        Do While InStr(sh.Cells(x, 1), ary(i)) = 1
            With sh
                If InStr(.Cells(x, 1), ary(i)) = 1 Then
                    .Cells(x, 5) = .Cells(x, 1).Value
                End If
            End With
            x = x - 1
        Loop
    Next
End Sub

 

[Lenna]

Thank you, it's amazing!

 

[JLGWhiz]

Thank you, it's amazing!

You're welcome,
Regards, JLG