excel - 从字典 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

现在，当我将字典中的项目打印到我的工作表时，我有以下几行：

        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}

唯一的问题是我不知道如何做到这一点。任何帮助将非常感激。干杯

标签： excelvba

Answer 1

我假设您只想将 A 到 G 列中的值复制到级别表中。这将在大约 5 秒内处理 100,000 行。它使用 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