Searching Multiple Criteria In Large Data Set to make new Data Set Excel VBA

0 votes

My very large data set is updated several times every day. It may have between 1000 and 20,000 entries. I have a macro that works, but it takes a very long time to go through all the points. It searches for specified criteria and creates a new table from that data. If there is a more elegant way to accomplish the same goal, please let me know.

I experimented with several new techniques for the same task. I looked at other options, but I was unable to make them work for my needs. Even the sophisticated filtering tables didn't work for me.

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
Jan 31, 2023 in Others by Kithuzzz
• 38,010 points
694 views

1 answer to this question.

0 votes

Copy the data to an array, filter to another array, and copy back to the sheet. 20,000 rows should take a few seconds.

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
answered Jan 31, 2023 by narikkadan
• 63,420 points

Related Questions In Others

0 votes
1 answer

Select data that meet criteria from a table, adding it to a combobox in userform VBA Excel

Fill Combo Box With Matches Sub GetSourceAcc() ...READ MORE

answered Mar 26, 2023 in Others by Kithuzzz
• 38,010 points
430 views
0 votes
1 answer

Creating a function in excel VBA to calculate the average point in a circular set of numbers

I used the following code to determine ...READ MORE

answered Oct 28, 2022 in Others by narikkadan
• 63,420 points
811 views
0 votes
1 answer

How can I sort one set of data to match another set of data in Excel?

In addition, INDEX MATCH is a more ...READ MORE

answered Oct 29, 2022 in Others by narikkadan
• 63,420 points
1,775 views
0 votes
1 answer

In a excel formula I need to create a list of names on one sheet based upon criteria/data of another sheet

The final formula is: =IF(ROWS($H$3:H3)<=$I$1,INDEX(Personnel! ...READ MORE

answered Nov 25, 2022 in Others by narikkadan
• 63,420 points
729 views
0 votes
1 answer

Retrieve epay.info Balance with VBA and Excel

This code should log you in, provided ...READ MORE

answered Sep 5, 2018 in Blockchain by digger
• 26,740 points
876 views
0 votes
1 answer

How to load file to Excel Power query from SFTP site

Currently, I don't think there is a ...READ MORE

answered Dec 3, 2018 in Power BI by Upasana
• 8,620 points
3,183 views
0 votes
1 answer

Using VBA Excel to create a gramatically correct list

The Excel AND function is a logical ...READ MORE

answered Feb 9, 2022 in Others by gaurav
• 23,260 points
480 views
0 votes
2 answers

How to copy a formula horizontally within a table using Excel VBA?

Hi so basically, create an adjacent column ...READ MORE

answered Feb 16, 2022 in Others by Edureka
• 13,670 points
731 views
0 votes
1 answer

Create unique rows in Excel with limited data to be used in multiple columns

This setup isn't readily generalizable, though since ...READ MORE

answered Oct 14, 2022 in Others by narikkadan
• 63,420 points
499 views
0 votes
1 answer

How can I use a command button in excel to set the value of multiple cells in one click?

Try this: Private Scan As Integer Private Sub CommandButton1_Click() ...READ MORE

answered Oct 24, 2022 in Others by narikkadan
• 63,420 points
508 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP