excel - 读取选择，将其加载到数组，处理并将其打印到下一列

Question

目标:在一列中加载一个或多个单元格的选择，然后用“_”分割数据。使用字符串并计算每个位置的每个字母的数量。
输入数据

输出应该是:

我正在尝试计算所有选定字符串范围的每个位置上每个字母 A、B、C 和 D 的频率，并将它们打印到下一个可用列。

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

输出应打印到下一个可用列。我写了 Destination = Range ("J2:K25")因为我不知道更好的方法。

Answer 1

这是一个通用代码，它并不假定总会有 ABCD .我已经对代码进行了注释，因此您理解代码不会有问题。

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

输出