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

0 votes

I have a very large Excel file that I use to cut, rather than copy, entire rows to another spreadsheet based on specific requirements. In addition to names (strings), numbers that begin with, for example, 45*, can also be used as search criteria. For smaller files, my code operates flawlessly, but for larger ones, it simply takes too long and occasionally even crashes. I'd like to add more functions to the code:

  1. Delete all existing tables except the main table.
  2. 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 was found in column "S" and transfer the complete row in a new sheet. The name of the new sheet should be the name of the defined criterion.
  3. 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: 

enter image description here

Jan 29, 2023 in Others by Kithuzzz
• 38,010 points
203 views

1 answer to this question.

0 votes

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

Related Questions In Others

0 votes
1 answer

How to import data from a HTML table on a website to excel?

Hello  To import any HTML file in excel there ...READ MORE

answered Feb 10, 2022 in Others by gaurav
• 23,260 points
5,902 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
482 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,706 views
0 votes
1 answer

How can I preserve the format while exporting data from excel to evernote

The contents for an Evernote note are ...READ MORE

answered Jan 5, 2023 in Others by narikkadan
• 63,420 points
296 views
0 votes
0 answers

Convert Rows to Columns with values in Excel using custom format

1 I having a Excel sheet with 1 ...READ MORE

Feb 17, 2022 in Others by Edureka
• 13,670 points
654 views
0 votes
1 answer

Remove formulas from all worksheets in Excel using VBA

Try this : Option Explicit Sub test1() ...READ MORE

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

Calculate monthly average from daily data without PivotTable

Assuming you have the months in column D enter ...READ MORE

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

Automate compound annual growth rate (CAGR) calculation

The following PowerPivot DAX formulas worked for ...READ MORE

answered Oct 7, 2022 in Others by narikkadan
• 63,420 points
931 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
667 views
0 votes
1 answer

Unable to import data in excel from another website using VB code

Replace : Set ieTable = ieDoc.all.Item("report-table") With: Set ieTable = ...READ MORE

answered Sep 21, 2022 in Others by narikkadan
• 63,420 points
440 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