如何扩展代码以根据多个条件将数据从一个电子表格传输到另一个电子表格

Question

我有一个非常大的 Excel 文件，我从中根据特定条件将完整的行（不是复制而是剪切）传输到另一个电子表格。搜索的条件不仅是名称（字符串），还可以是以例如开头的数字。 45*。我创建的代码适用于较小的文件，但对于较大的文件来说，它花费的时间太长，有时甚至会崩溃。 我想用更多功能扩展代码：

1. 删除除主表之外的所有现有表。
2. 搜索多个条件（例如“政府”、“中端市场”、“45“，“企业”），可以出现在“S”列中，并为在“S”列中找到的每个标准创建一个新表，并将完整行传输到新表中。新表的名称应该是名称定义的标准。
3. 通过状态或进度条显示进度。

   这是我目前使用的代码：

   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
   

   状态或进度条可能如下所示：

Answer 1

这应该只需要几秒钟，所以进度条是不必要的。

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, grp As String
    Dim r1 As Long, r2 As Long, rCopy As Long
    Dim t0 As Single
    
    arCrit = Array("Northmarket", "Midmarket", "Southmarket", "inside", "outside", "123*")
    
    Dim group As Object
    Set group = CreateObject("Scripting.Dictionary")
    With group
        .Add "Northmarket", "Market"
        .Add "Southmarket", "Market"
        .Add "Midmarket", "Market"
        .Add "outside", "InOutSide"
        .Add "inside", "InOutSide"
    End With
    
    Set wb = ThisWorkbook
    Set wsSrc = wb.Sheets("InstallBase")
    
    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)
        
        ' use aggregate name for sheet if one
        If group.exists(s) Then
            grp = group(s)
        Else
            grp = s
        End If
        
        On Error Resume Next
        Set ws = wb.Sheets(grp)
        On Error GoTo 0
        ' create sheet or clear existing
        If ws Is Nothing Then
            Set ws = wb.Sheets.Add(after:=wsSrc)
            ws.Name = Replace(grp, "*", "~")
            wsSrc.Range(HDR).Copy ws.Range("A1")
        End If
        rCopy = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
        
        ' 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("A" & rCopy)
            rCopy = rCopy + rng.Rows.Count
            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) = Replace(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
        
    'Application.ScreenUpdating = False
    With ws
        .Cells.Clear
        .Range("A1").Resize(n, 29) = x
    End With
    'Application.ScreenUpdating = True
    MsgBox i - 1 & " rows of test data created", vbInformation, _
          "Took " & Format(Timer - t0, "0.0 secs")
End Sub