Reading a selection, loading it to array, processing and printing it to the next column

Question

Goal: Load a selection of one or multiple cells in a column and then split the data by "_". Use the string and count the number of each letter at each position.

Input Data

The output should be:

I am trying to calculate the frequency of each letter A, B, C and D at every position of all the selected range of strings and print them to the next available column.

Option Explicit
Sub Count_ABCD() 

Dim cell As Range

'Next task is to select a range of sequences and do the following
'Trying to use the selection and accesing one cell at a time.
For Each cell In Cells(ActiveCell.Column, "A")

    Dim Yourseq As String
    Dim arr() As String
    Dim StoreA() As Variant
    Dim StoreB() As Variant
    Dim StoreC() As Variant
    Dim StoreD() As Variant
    Dim i As Long
    Dim Destination As Range
    
    Yourseq = cell.Value 'take a sequence and store it in a variable

    Range("G2").Value = Len(Yourseq) 'show the length of the sequence in the next cell
    arr = Split(Yourseq, "_")

    'Apparently for performance purposes we need to resize our dynamic array in VBA
    ReDim StoreA(1 To Len(arr(1)))
    ReDim StoreB(1 To Len(arr(1)))
    ReDim StoreC(1 To Len(arr(1)))
    ReDim StoreD(1 To Len(arr(1)))
    Set Destination = Range("J2:K25") 'Start printing here
    
    'First take one sequence length and create 4 arrays (for each letter)
    ' and fill them with 0s
    For i = 1 To Len(arr(1))
        StoreA(i) = 0
        StoreB(i) = 0
        StoreC(i) = 0
        StoreD(i) = 0
    Next

    For i = 1 To Len(arr(1))
        'Check whether the string is A/B/C/D then add plus one to each array index
        If UCase(Mid(arr(1), i, 1)) = "A" Then
            StoreA(i) = StoreA(i) + 1
        ElseIf UCase(Mid(arr(1), i, 1)) = "B" Then
            StoreB(i) = StoreB(i) + 1
        ElseIf UCase(Mid(arr(1), i, 1)) = "C" Then
            StoreC(i) = StoreC(i) + 1
        ElseIf UCase(Mid(arr(1), i, 1)) = "D" Then
            StoreD(i) = StoreD(i) + 1
        End If
    Next

    'Range("I2").Value = (UBound(StoreA) - LBound(StoreA) + 1)
    Range("I2").Value = arr(1)

    'Resize an array to the preferred range of values
    Set Destination = Destination.Resize(1, UBound(StoreA))

    Destination.Value = StoreB 'Print an array to the preferred range of values
    
Next cell

End Sub

The output should be printed to the next available column. I wrote Destination = Range ("J2:K25") cause I didn't know a better way.

user_1140579 · Answer

Here is a generic code which doesn't assume that there will always be ABCD. I have commented the code so you will not have a problem understanding the code.

Option Explicit

Sub Sample()
    Dim wsInput As Worksheet, wsOutput As Worksheet
    Dim Ar As Variant, OutputAr As Variant
    Dim lRow As Long
    Dim i As Long, j As Long, k As Long
    Dim ArLen As Long
    Dim MatchChar As String
    
    Set wsInput = Sheet1    '<~~ Input Sheet
    Set wsOutput = Sheet2   '<~~ Output Sheet where you want output
    
    '~~> Find last row in Col A in input sheet
    lRow = wsInput.Range("A" & wsInput.Rows.Count).End(xlUp).Row
        
    '~~> Store the values in an array
    Ar = wsInput.Range("A1:A" & lRow).Value2
    
    '~~> Clean the array and get rid of unwanted characters (*_)
    '~~> Also get the max length of the chars in a cell. Currently
    '~~> You have 4 chars ABCD [See CASE 1 Below]
    '~~> What if in some column you have ABCDE? [See CASE 2 Below]
    For i = LBound(Ar) To UBound(Ar)
        If InStr(1, Ar(i, 1), "_") Then Ar(i, 1) = Split(Ar(i, 1), "_")(1)
        
        If Len(Trim(Ar(i, 1))) > ArLen Then ArLen = Len(Trim(Ar(i, 1)))
    Next i
            
    '~~> Define your output array
    ReDim OutputAr(1 To ArLen, 1 To ArLen)
    
    '~~> Loop though the rows
    For i = 1 To lRow
        '~~> Loop through char length
        For j = 1 To ArLen
            '~~> Get the character we are going to match
            MatchChar = Mid(Trim(Ar(1, 1)), i, 1)
            '~~> Set the value to 0
            On Error Resume Next
            OutputAr(j, i) = 0
            On Error GoTo 0
            
            '~~> Loop through the cells and get the macth count
            For k = 1 To lRow
                'Debug.Print MatchChar; "-"; Mid(Trim(Ar(k, 1)), j, 1)
                If Mid(Trim(Ar(k, 1)), j, 1) = MatchChar Then
                    OutputAr(j, i) = OutputAr(j, i) + 1
                End If
            Next k
        Next j
    Next i
    
    '~~> Output to cell A1 of sheet2
    wsOutput.Range("A1").Resize(ArLen, ArLen).Value = OutputAr
End Sub

Output

user_3219613 · Answer

I would do it that way:

Option Explicit

Public Sub GererateMatrix()
    Const Characters As String = "ABCD"
    
    Dim Matrix() As Variant
    ReDim Matrix(1 To Len(Characters) + 1, 1 To Len(Characters)) As Variant
    
    ' write headers
    Dim iChar As Long
    For iChar = 1 To Len(Characters)
        Matrix(1, iChar) = Mid$(Characters, iChar, 1)
    Next iChar
    
    ' get data from selection
    Dim ProcessRange As Range
    Set ProcessRange = Selection
    
    ' get data into array
    Dim Data() As Variant
    If ProcessRange.Cells.CountLarge = 1 Then
        ' handle one cell selection
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = ProcessRange.Value
    Else
        ' handle multi cell selection
        Data = ProcessRange.Value
    End If
    
    Dim Item As Variant
    For Each Item In Data  ' loop through all data items
        Dim Sequence As String
        Sequence = Split(Item, "_")(1) 'split off number and underscore
        
        ' fill matrix counts
        For iChar = 1 To Len(Characters)
            Dim Char As String
            Char = Mid$(Sequence, iChar, 1)
            
            Dim CharPos As Long
            CharPos = InStr(1, Characters, Char)
            
            Matrix(iChar + 1, CharPos) = Matrix(iChar + 1, CharPos) + 1
        Next iChar
    Next Item
    
    ' Output Matrix
    ProcessRange.Offset(ColumnOffset:=1).Resize(Len(Characters) + 1, Len(Characters)).Value = Matrix
End Sub

From the following selected range it will generate the output right of it:

Reading a selection, loading it to array, processing and printing it to the next column

2 Answers