Извлечение хранимых данных из словаря VBA

Question

У меня есть словарь, который я заполнил информацией, которую я извлек из основной таблицы с примерно 65 000 уникальных строк. Затем я хотел бы отфильтровать словарь и извлечь элементы, только если они содержат определенное значение. Ниже приведен мой код для создания словаря из исходных данных, который я заимствовал из других методов, которые я нашел в Интернете:

Sub dict_extract()

    Dim cell    As Range
    Dim Data    As Variant
    Dim Dict    As Object
    Dim Item    As Variant
    Dim Key     As Variant
    Dim rng     As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet
    Dim x       As Long
    Dim y       As Long
    Dim i As Long


'Speed Up
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

        Set Wks = ThisWorkbook.Worksheets("FullCarriers")

        Set RngBeg = Wks.Range("A2:G2")
        Set RngEnd = Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp)

        If RngEnd.Row < RngBeg.Row Then Exit Sub

        Set rng = Wks.Range(RngBeg, RngEnd)

        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare



            For Each cell In rng.Columns(1).Cells
                Key = Trim(cell)
                Item = cell.Resize(1, rng.Columns.Count).Value

                If Not Dict.Exists(Key) Then
                    Dict.Add Key, Item
                Else
                    ' To increase the rows in the 2-D array it must first be transposed.
                    ' Only the last dimension of an array can be resized.
                    Data = Application.Transpose(Dict(Key))
                        x = UBound(Data, 1)
                        y = UBound(Data, 2) + 1
                        ReDim Preserve Data(1 To x, 1 To y)
                    ' Transposing the array a second time restores the original order.
                    Data = Application.Transpose(Data)

                    ' Load the new data.
                    For x = 1 To UBound(Item, 2)
                        Data(y, x) = Item(1, x)
                    Next x

                    ' Save the Data.
                    Dict(Key) = Data
                End If
            Next cell

Теперь, когда я go, чтобы напечатать элементы в словаре для мои рабочие листы, у меня есть следующие строки:

        For i = 2 To 14

            Set rng = ActiveWorkbook.Sheets("Level " & i).Range("A2")

            For Each Item In Dict.items
                x = UBound(Item, 1)
                y = UBound(Item, 2)
                rng.Resize(x, y).Value = Item
                Set rng = rng.Offset(x, 0)
            Next Item

        Next i

Что я хотел бы сделать, так это когда я перебираю элементы словаря, проверяю, содержат ли они определенный символ, и печатает на моем листе, если они содержат этот персонаж, и ничего не делать, если они этого не делают. «Код», который мне нужно отфильтровать, выглядит примерно так:

If Mid(Item,13,2) = Format(i, "00") Then
{Print to Worksheet i}
Else
{Do Nothing}

Единственная проблема в том, что я понятия не имею, как это сделать sh. Любая помощь приветствуется. Приветствия

Answer 1

Я предположил, что вы хотите, чтобы значения в столбцах от A до G копировались на листы уровня. Это обрабатывает 100 000 строк примерно за 5 секунд. Он использует 2 14 массивов элементов для хранения целевого листа и целевой строки для каждого значения i.

Option Explicit
Sub process()

    Const IVALUES As Integer = 14
    Const SRC = "FullCarriers"

    Dim t0 As Single, t1 As Single
    t0 = Timer
    Dim wb As Workbook, ws As Worksheet
    Dim i As Long, iRow As Long, iRowLast As Long
    Dim iID As Integer, sID As String

    ' set row counter for each sheet
    Dim iRowTarget(IVALUES) As Long
    Dim wsTarget(IVALUES) As Worksheet, rngTarget As Range

    Set wb = ThisWorkbook
    For i = 1 To IVALUES
        Set wsTarget(i) = wb.Sheets("Level " & i) ' sheet name
        iRowTarget(i) = 1
    Next

    ' clear cheets
    For Each ws In wb.Sheets
        If ws.Name Like "Level?#" Then
            ws.Cells.Clear
            'Debug.Print ws.Name
        End If
    Next

    ' scan the source data sheet
    Set ws = wb.Sheets(SRC)
    iRowLast = ws.Range("A" & Rows.Count).End(xlUp).Row

    ' start at row 2
    Application.ScreenUpdating = False
    With ws
    For iRow = 2 To iRowLast

        sID = Mid(.Cells(iRow, 1), 13, 2)
        If sID Like "##" And sID <= IVALUES Then

            iID = CInt(sID)
            ' copy cola A to G
            Set rngTarget = wsTarget(iID).Range("A" & iRowTarget(iID) & ":G" & iRowTarget(iID))
            rngTarget.Value = .Range("A" & iRow & ":G" & iRow).Value
            iRowTarget(iID) = iRowTarget(iID) + 1

        Else
            MsgBox "Incorrect pattern " & sID & " at Row " & iRow
        End If

    Next
    End With
    t1 = Timer
    Application.ScreenUpdating = True
    Application.StatusBar = "Finished at Row " & iRow

    MsgBox iRowLast & " rows scanned ", vbInformation, "Finished in " & Int(t1 - t0) & " seconds"

End Sub

Эти сценарии, которые я использовал для генерации тестовых данных

Sub testdata()

    Dim wb As Workbook, ws As Worksheet, wsAdd As Worksheet
    Dim i As Long, n As Integer
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("FullCarriers")
    ws.Cells.Clear

    ' create 14 sheets
    ' n = wb.Sheets.Count
    ' For i = 0 To 13
    '  Set wsAdd = wb.Sheets.Add(after:=Sheets(n + i))
    '  wsAdd.Name = "Level " & i + 1
    ' Next

    Dim s As String, sID As String, sNo As String
    For i = 2 To 100001
        sID = Format(Int(1 + Rnd() * 14), "00")
        sNo = Format(Int(1 + Rnd() * 99), "00")
        ' example F_LTC91-ABS-01-xx-yy
        s = rndStr(1) & "_" & rndStr(3) & sNo & "-" & rndStr(3) & "-" & sID & _
        "-" & rndStr(2) & "-" & rndStr(2)
        ws.Cells(i, 1) = s
        ws.Cells(i, 2) = "Row " & i & " Col B"
        ws.Cells(i, 3) = sID
        ws.Cells(i, 7) = "Row " & i & " Col G"
    Next

End Sub

Function rndStr(ByVal n As Integer) As String
   Dim i As Integer
   For i = 1 To n
     rndStr = rndStr & Chr(Rnd() * 25 + 65)
   Next
End Function