循環過濾列表並將元素附加到數組

Question

工作表「FRT」包含過濾的數據。對於列A中的每個字母，僅當列B與「B2」中的單元格值匹配時，我將C列中的相應值附加到對應的數組中。 A列可以包含字母（A-S）的任何組合或不包含任何字母。我的代碼只適用於列A中存在所有字母的情況，但是，如果它們中的任何一個都丟失，我會收到一條錯誤消息。另外，我的代碼非常冗長。請建議如何改進它。
中，我有 「A」 至 「C」 唯一代碼：

Sub test() 

    Dim acat As Variant, cell As Range 
    Dim bcat As Variant 
    Dim ccat As Variant 
    Dim sht As Worksheet 

    Set sht = ThisWorkbook.Worksheets("FRT") 

    LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 

    ReDim fcat(0) 
    ReDim bcat(0) 
    ReDim ccat(0) 

    For Each cell In Worksheets("FRT").Range("A6:C" & LastRow).SpecialCells(xlCellTypeVisible) 

     If cell.Value = "A" And cell.Offset(0, 1).Value = Range("B2").Cells Then 
        MsgBox (Range("B2").Cells) 
        acat(UBound(acat)) = cell.Offset(0, 2).Value 
        ReDim Preserve acat(UBound(acat) + 1) 
     ElseIf cell.Value = "B" And cell.Offset(0, 1).Value = Range("B2").Cells Then 
        bcat(UBound(bcat)) = cell.Offset(0, 2).Value 
        ReDim Preserve bcat(UBound(bcat) + 1) 
     ElseIf cell.Value = "C" And cell.Offset(0, 1).Value = Range("B2").Cells Then 
        ccat(UBound(ccat)) = cell.Offset(0, 2).Value 
        ReDim Preserve ccat(UBound(ccat) + 1) 
     End If 
      Next cell 
      ReDim Preserve acat(UBound(fcat) - 1) 
      ReDim Preserve bcat(UBound(bcat) - 1) 
      ReDim Preserve ccat(UBound(ccat) - 1) 

      Range("D1") = Join(acat, " ") 
      Range("E1") = Join(bcat, " ") 
      Range("F1") = Join(ccat, " ") 



End Sub 

這是視覺數據的

謝謝

Answer 1

Sub test() 

    Dim cell As Range, lastrow As Long 
    Dim sht As Worksheet 
    Dim cats(1 To 1, 1 To 19), seps(1 To 19), tmp, i 

    Set sht = ThisWorkbook.Worksheets("FRT") 

    lastrow = sht.Cells(Rows.Count, 1).End(xlUp).Row 

    For Each cell In Worksheets("FRT").Range("A6:A" & _ 
          lastrow).SpecialCells(xlCellTypeVisible) 

     If cell.Offset(0, 1).Value = Range("B2").Value Then 
      tmp = cell.Value 
      If tmp Like "[A-S]" Then 
       i = Asc(tmp) - 64 'Asc("A") is 65... 
       cats(1, i) = cats(1, i) & seps(i) & cell.Offset(0, 2).Value 
       seps(i) = " " 'next time we'll add a space for this category 
      End If 
     End If 
    Next cell 

    Range("D1").Resize(1, 19) = cats 

End Sub 

Answer 2

此版本使用數組和字典對象（Tim的效率更高，更容易維護）

Option Explicit 

Sub test() 
    Const FIRST_ROW As Byte = 6 
    Const A_VALS As String = "A B C D E F G H I J K L M N O P R S" 

    Dim ws As Worksheet, lRow As Long, b2 As String, i As Long, j As Long 
    Dim ltr As Variant, ltrs As Variant, arr As Variant, d As Object, done As Boolean 

    Set ws = ThisWorkbook.Worksheets("FRT") 
    lRow = ws.Cells(ws.UsedRange.Row + ws.UsedRange.Rows.Count, 2).End(xlUp).Row 

    arr = ws.Range("A" & FIRST_ROW & ":C" & lRow) 
    b2 = ws.Range("B2").Value2 
    ltrs = Split(A_VALS) 

    Set d = CreateObject("Scripting.Dictionary") 

    For i = 1 To lRow - FIRST_ROW + 1 
     If ws.Rows(i + FIRST_ROW - 1).Height > 0 Then 
      For Each ltr In ltrs 
       If arr(i, 1) = ltr And arr(i, 2) = b2 Then 
        d(ltr) = d(ltr) & " " & arr(i, 3) 
        done = True: Exit For 
       Else 
        If done Or arr(i, 2) <> b2 Then Exit For 
       End If 
      Next: done = False 
     End If 
    Next 
    i = 4 
    For Each ltr In ltrs 
     If Len(d(ltr)) > 0 Then ws.Cells(1, i) = d(ltr) 
     i = i + 1 
    Next 
    ws.Range(ws.Cells(1, 4), ws.Cells(1, i)).Columns.AutoFit 
End Sub