excel - 循环优化/定制

Question

我拥有的 excel 文件超过 1,000,000 行和 26 列。
下面是用于查找特定数据的代码，并根据该数据创建一个新文件，目前创建一个新文件大约需要 15 分钟
请如果有专家可以帮助我更快地处理以下宏。

Sub SplitSheetDataIntoMultipleWorkbooksBasedOnSpecificColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
 
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
 
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
   
    strColumnValue = "1021 VDDGC 104"
 
    If objDictionary.Exists(strColumnValue) = False Then
       objDictionary.Add strColumnValue, 1
    End If
 
    varColumnValues = objDictionary.Keys  
 
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
 
        'Create a new Excel workbook
        Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
 
        objWorksheet.Rows(1).EntireRow.Copy
        objSheet.Activate
        objSheet.Range("A1").Select
        objSheet.Paste
 
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("K" & nRow).Value) = CStr(varColumnValue) Then
               'Copy data with the same column "B" value to new workbook
               objWorksheet.Rows(nRow).EntireRow.Copy
  
               nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
               objSheet.Range("A" & nNextRow).Select
               objSheet.Paste
               objSheet.Columns("A:S").AutoFit
            End If
        Next
    Next
End Sub

Answer 1

将工作表复制到新工作簿

将工作表复制(导出)到新工作簿。

按条件列排序和过滤。

删除过滤的行。

Sub SplitWorksheetData()

    Dim dt As Double: dt = Timer
    
    Const Criteria As String = "1021 VDDGC 104"
    Const CriteriaColumnIndex As Long = 2
    
    Dim sws As Worksheet: Set sws = ActiveSheet ' improve!
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    If Not dict.Exists(Criteria) Then dict.Add Criteria, 1
 
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim Key As Variant

    For Each Key In dict.Keys
        
        sws.Copy
        Set dwb = Workbooks(Workbooks.Count)
        Set dws = dwb.Worksheets(1)
        If dws.FilterMode Then dws.ShowAllData
         
        Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion
        Dim ddrg As Range: Set ddrg = drg.Resize(drg.Rows.Count - 1).Offset(1)
        
        drg.Sort drg.Columns(CriteriaColumnIndex), xlAscending, , , , , , xlYes
        drg.AutoFilter CriteriaColumnIndex, "<>" & Criteria
         
        Dim vrg As Range
        On Error Resume Next
            Set vrg = ddrg.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        dws.AutoFilterMode = False
        
        If Not vrg Is Nothing Then vrg.Delete
 
        ' Save code goes here...
        'dwb.SaveAs... 

    Next Key
    
    Application.ScreenUpdating = True

    Debug.Print Timer - dt

    MsgBox "Workbook created.", vbInformation

End Sub