Question

工作表“FRT”包含已过滤的数据。对于列A中的每个字母，仅当列B与“B2”中的单元格值匹配时，我将列C中的相应值附加到相应的数组中。 A列可以包含任何字母组合（A-S）或不包含任何字母组合。我的代码仅在A列中存在所有字母时才有效，但是，如果缺少任何字母，我会收到错误消息。此外，我的代码很长且多余。请建议如何改进它我为＆＃34; A＆＃34;提供了代码。到＆＃34; C＆＃34;只有：

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

循环遍历筛选列表并将元素追加到数组

2 个答案: