How to expend the code to transfer data from one spreadsheet to another based on multiple criteria-CodePudding

I have a very large Excel file from which I transfer complete rows (not copy but cut) to another spreadsheet based on certain criteria.The searched criteria are not only names (string), it can also be numbers that start with e.g. 45*. My created code works fine for smaller files, but for larger ones it just takes too long, sometimes it even crashes. I would like to extend the code with more functions:

Delete all existing tables except the main table.
Search for several criteria (e.g. "Government", "Midmarket", "45", "Enterprise") that can occur in column "S" and create a new table for each criterion which were found in column "S" and transfer the complet row in a new sheet. The name of the new sheet should be the name of defined criterion.
Show the progress via a status or progress bar.

Here is the code I currently use:

Sub VTest()

    Dim LastRow         As Long
    Dim CurrentRow      As Long
    Dim SourceSheetName As String

    SourceSheetName = "InstallBase"                                                 ' <--- Set this to name of the Source sheet
   
    Application.ScreenUpdating = False                                              ' Turn ScreenUpdating off to prevent screen flicker

   
    Sheets.Add after:=Sheets(SourceSheetName)                                       ' Add a new sheet after the Source sheet
    ActiveSheet.Name = "Midmarket"                                                      ' Assign a name to newly created sheet

    Sheets(SourceSheetName).Range("A1:AC1").Copy Sheets("Midmarket").Range("A1:AC1")    ' Copy Header rows from Source sheet to the new sheet

    LastRow = Sheets(SourceSheetName).Range("A" & Rows.Count).End(xlUp).Row         ' Determine Last used row in column A

    For CurrentRow = LastRow To 2 Step -1                                           ' Start at LastRow and work backwards, row by row, until beginning of data
        If Sheets(SourceSheetName).Range("S" & CurrentRow).Value Like "Midmarket" Then  '   If we encounter a 'Yes' in column S then copy the row to new sheet
            Sheets(SourceSheetName).Rows(CurrentRow).Copy Sheets("Midmarket").Range("A" & Rows.Count).End(xlUp).Offset(1)
            Sheets(SourceSheetName).Rows(CurrentRow).Delete                         '   Delete the row from the Source sheet that contained 'Yes' in column S
        End If
    Next                                                                            ' Continue checking previous row


    Application.ScreenUpdating = True                                               ' Turn ScreenUpdating back on
End Sub

The status or progress bar can look like this:

CodePudding user response：

This should only take seconds so the progress bar is unnecessary.

Option Explicit

Sub VTest2()

    Const COL_FILTER = 19 ' S
    Const HDR = "A1:AC1"

    Dim wb As Workbook, wsSrc As Worksheet, ws As Worksheet
    Dim rng As Range, rng1 As Range
    Dim arCrit, i As Long, lastrow As Long, lastCol As Long
    Dim s As String
    Dim r1 As Long, r2 As Long
    Dim t0 As Single
    
    arCrit = Array("Government", "Midmarket", "45", "99", "123", "Enterprise", "ABC", "DEF")
    
    Set wb = ThisWorkbook
    Set wsSrc = wb.Sheets("InstallBase")
    
    ' uncomment this to create test data
    'Call CreateTestData(wsSrc, 10000, arCrit, COL_FILTER)
    
    ' Delete all existing tables except the main table.
    t0 = Timer
    Application.DisplayAlerts = False
    For Each ws In wb.Sheets
        If ws.Name <> wsSrc.Name Then
            ws.Delete
        End If
    Next
    Application.DisplayAlerts = True
        
    ' sort
    Application.ScreenUpdating = False
    With wsSrc
        lastrow = .Cells(.Rows.Count, COL_FILTER).End(xlUp).Row
        lastCol = .UsedRange.Columns.Count
        ' add row counter to preserve order
        For i = 1 To lastrow
           .Cells(i, lastCol   1) = i
        Next
        With .Sort
           .SortFields.Clear
           .SortFields.Add2 Key:=wsSrc.Cells(1, COL_FILTER), _
            SortOn:=xlSortOnValues, Order:=xlDescending, _
            DataOption:=xlSortNormal
            .SetRange wsSrc.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
                
    End With
            
    ' loop criteria
    For i = LBound(arCrit) To UBound(arCrit)
        s = arCrit(i)
        On Error Resume Next
        Set ws = wb.Sheets(s)
        On Error GoTo 0
        ' create sheet or clear existing
        If ws Is Nothing Then
            Set ws = wb.Sheets.Add(after:=wsSrc)
            ws.Name = s
        Else
            ws.Cells.Clear
        End If
        wsSrc.Range(HDR).Copy ws.Range("A1")
        
        ' is this a * match
        If IsNumeric(s) Then s = s & "*"
        
        ' find first match
        Set rng = wsSrc.Columns(COL_FILTER).Find(s, LookIn:=xlValues, lookat:=xlWhole)
        If rng Is Nothing Then
        Else
            r1 = rng.Row ' first
            ' find last
            Do While rng.Offset(1) Like s
                Set rng = rng.Offset(1)
            Loop
            r2 = rng.Row
            
            Set rng = wsSrc.Range(HDR).Offset(r1 - 1).Resize(r2 - r1   1)
            Debug.Print s, r1, r2, r2 - r1, rng.Address
            
            rng.Copy ws.Range("A2")
            rng.EntireRow.Delete
            
        End If
        Set ws = Nothing
    Next
    
    ' restore order
     With wsSrc
        With .Sort
           .SortFields.Clear
           .SortFields.Add2 Key:=wsSrc.Cells(1, lastCol   1), _
            SortOn:=xlSortOnValues, Order:=xlAscending, _
            DataOption:=xlSortNormal
            .SetRange wsSrc.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Columns(lastCol   1).Delete
    End With
    Application.ScreenUpdating = True
    
    MsgBox wb.Sheets.Count - 1 & " sheets created", vbInformation, "Took " & Format(Timer - t0, "0.0 secs")
    
End Sub

Sub CreateTestData(ws, n, ar, c)
    Dim i As Long, j As Long, x, t0 As Single
    t0 = Timer
    ReDim x(1 To n, 1 To 29)
    For j = 1 To 29 'AC
        x(1, j) = "Header " & j
    Next
    For i = 2 To n
        For j = 1 To 29 'AC
           x(i, j) = Split(Cells(i, j).Address(0, 0, xlA1), ":")(0)
        Next
        ' 50% other data
        If Int(Rnd * 2) = 1 Then
            x(i, c) = ar(Rnd * UBound(ar))
            If IsNumeric(x(i, c)) Then
                x(i, c) = x(i, c) & Format(10000 * Rnd, "00000")
            End If
        Else
            x(i, c) = "Other data"
        End If
    Next

    With ws
        .Cells.Clear
        .Range("A1").Resize(n, 29) = x
    End With
    MsgBox i - 1 & " rows of test data created", vbInformation, _
          "Took " & Format(Timer - t0, "0.0 secs")
End Sub