大型数据集多条件检索生成新数据集Excel VBA

ie3xauqp 于 2023-02-05 发布在其他

关注(0)|答案(1)|浏览(195)

我有一个非常大的数据集，每天更新多次。它可以从1000到20000个条目。我有一个宏，搜索特定的条件，并从该数据和工作，但它需要很长的时间来筛选所有的点。我想知道是否有一个更雄辩的方式来达到同样的结果。
我尝试了一种新的不同的方法来处理同一件事。我四处寻找其他的解决方案，但无法让它们符合我的需要。我甚至尝试了高级过滤表，但无济于事。

Function AgedDivert()
    
    'Pull from scraped data to display compact data set
    On Error GoTo ErrorHandler
    ufProgress.Caption = "Loading Aged Divert"
    ufProgress.LabelProgress.Width = 0
    
    pasterow = 31
    sname = "Aged Divert Report"
    ThisWorkbook.Sheets(sname).Rows(30 & ":" & 999999).Clear
    ThisWorkbook.Sheets("Temp").Range("1:1").Copy ThisWorkbook.Sheets(sname).Range("30:30")
    RowCount = WorksheetFunction.CountA(ThisWorkbook.Sheets("Scraped Data").Range("A:A"))
    'Create new data sort by age and location
    For i = 2 To RowCount
        pctComplete = (i - 2) / (RowCount - 2)
        'Filter out Direct Loads, PA2, Less than 180 Minutes, Secondary, not diverted
        If Len(ThisWorkbook.Sheets("Scraped Data").Range("D" & i).Value) <> 2 And _
         (ThisWorkbook.Sheets("Scraped Data").Range("J" & i).Value = "Ship Sorter" Or _
         ThisWorkbook.Sheets("Scraped Data").Range("K" & i).Value = "Divert Confirm") And _
         ThisWorkbook.Sheets("Scraped Data").Range("D" & i).Value <> "" And _
         ThisWorkbook.Sheets("Scraped Data").Range("M" & i).Value > 180 And _
         ThisWorkbook.Sheets("Scraped Data").Range("I" & i).Value <> "Left to Pick" And _
         InStr(1, ThisWorkbook.Sheets("Scraped Data").Range("C" & i).Value, "Location") = 0 And _
         (InStr(1, ThisWorkbook.Sheets("Scraped Data").Range("C" & i).Value, "Warehouse A") > 0 Or _
         InStr(1, ThisWorkbook.Sheets("Scraped Data").Range("C" & i).Value, "Warehouse C") > 0 Or _
         InStr(1, ThisWorkbook.Sheets("Scraped Data").Range("C" & i).Value, "PA") = 0) Then
            ThisWorkbook.Sheets("Scraped Data").Range(i & ":" & i).Copy ThisWorkbook.Sheets(sname).Range(pasterow & ":" & pasterow)
            pasterow = pasterow + 1
        End If
        ufProgress.LabelProgress.Width = pctComplete * ufProgress.FrameProgress.Width
        ufProgress.Repaint
    Next i
    ufProgress.Caption = "Loading Complete. Cleaning Data"
    
    'Remove Unnecessary Data
    ThisWorkbook.Sheets(sname).Columns("R").Delete
    ThisWorkbook.Sheets(sname).Columns("Q").Delete
    ThisWorkbook.Sheets(sname).Columns("O").Delete
    ThisWorkbook.Sheets(sname).Columns("N").Delete
    ThisWorkbook.Sheets(sname).Columns("L").Delete
    ThisWorkbook.Sheets(sname).Columns("K").Delete
    ThisWorkbook.Sheets(sname).Columns("J").Delete
    ThisWorkbook.Sheets(sname).Columns("H").Delete
    ThisWorkbook.Sheets(sname).Columns("F").Delete
    ThisWorkbook.Sheets(sname).Columns("E").Delete
    ThisWorkbook.Sheets(sname).Range("C30:C999999").Delete
    ThisWorkbook.Sheets(sname).Range("B30:B999999").Delete
    'Set Data as Table
    ThisWorkbook.Sheets(sname).ListObjects.Add(xlSrcRange, ThisWorkbook.Sheets(sname).Range("A30:F" & pasterow), , xlYes).Name = "AgedDivert"
    
    AgedDivert = True
    Exit Function
ErrorHandler:
    AgedDivert = False
    Debug.Print "Error occured in Aged Divert"
    Debug.Print Err.Number & ": " & Err.Description
End Function

excel

来源：https://stackoverflow.com/questions/75285346/searching-multiple-criteria-in-large-data-set-to-make-new-data-set-excel-vba

1条答案

按热度按时间

lstz6jyr1#

将数据复制到一个数组，过滤到另一个数组，然后复制回工作表。20，000行应该需要几秒钟。

Function AgedDivert()
    
    Dim wb As Workbook
    Dim wsData As Worksheet, wsReport As Worksheet, wsTemp As Worksheet
    Dim arData, arReport
    Dim lastrow As Long, i As Long, r As Long
    Dim colC, colD, colI, colJ, colK, colM, msg As String
    Dim t0 As Single: t0 = Timer
    
    Const RPT_NAME = "Aged Divert Report"
    
    'Pull from scraped data to display compact data set
    On Error GoTo ErrorHandler
    
    Set wb = ThisWorkbook
    With wb
        Set wsData = .Sheets("Scraped Data")
        Set wsReport = .Sheets(RPT_NAME)
        Set wsTemp = .Sheets("Temp")
    End With
     
    ' copy data
    With wsData
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        ' copy sheet to array
        arData = .Range("A1:P" & lastrow)
        ReDim arReport(1 To lastrow, 1 To 6) ' A to F
        For i = 2 To lastrow
            
            colC = arData(i, 3)
            colD = arData(i, 4)
            colI = arData(i, 9)
            colJ = arData(i, 10)
            colK = arData(i, 11)
            colM = arData(i, 13)
            
            'Filter out Direct Loads, PA2, Less than 180 Minutes,
            'Secondary, not diverted
            If Len(colD) <> 2 And colD <> "" And _
                (colJ = "Ship Sorter" Or colK = "Divert Confirm") _
                And colM > 180 _
                And colI <> "Left to Pick" _
                And InStr(1, colC, "Location") = 0 And _
                (InStr(1, colC, "Warehouse A") > 0 Or _
                InStr(1, colC, "Warehouse C") > 0 Or _
                InStr(1, colC, "PA") = 0) Then
                
                r = r + 1 ' report row
                arReport(r, 1) = arData(i, 1) ' A
                arReport(r, 2) = arData(i, 4) ' D
                arReport(r, 3) = arData(i, 7) ' G
                arReport(r, 4) = arData(i, 9) ' I
                arReport(r, 5) = arData(i, 13) ' M
                arReport(r, 6) = arData(i, 16) ' P
                
             End If
        Next i
    End With
    
    ' output
    With wsReport
        ' delete existing table
        .Rows("30:" & .Rows.Count).Clear
        .Range("A30:F30") = Array("Col A", "Col D", "Col G", "Col I", "Col M", "Col P")
        If r = 0 Then
            MsgBox "No data to report", vbExclamation
        Else
            ' copy rows and set Data as Table
            .Range("A31").Resize(r, 6) = arReport
            .ListObjects.Add(xlSrcRange, .Range("A30:F" & 30 + r), xlYes).Name = "AgedDivert"
        End If
    End With
  
    
    msg = lastrow - 1 & " rows scanned from " & wsData.Name & vbLf & _
          r & " rows copied to " & wsReport.Name
    MsgBox msg, vbInformation, Format(Timer - t0, "0.0 secs")
    
    AgedDivert = True
    Exit Function
    
ErrorHandler:
    AgedDivert = False
    Debug.Print "Error occured in Aged Divert"
    Debug.Print Err.Number & ": " & Err.Description
End Function

赞(0）回复(0）举报 2023-02-05

我来回答

大型数据集多条件检索生成新数据集Excel VBA

1条答案

相关问题

热门标签

最新问答