对数据块运行 Excel 宏

Question

大约 60,000 行的数据集将被拆分为 200 个几乎相同大小的文件。 运行这通常需要大约 4 小时，而在 20,000 行的初始数据集上运行相同的宏需要大约半小时。 因此，我计划在每个大约 20,000 行的数据“块”上运行宏（实际拆分将基于单个文件的数量，其名称是初始文件中列的条目），并且我想知道是否有一种简单的方法可以在新的逐块宏中“包装”原始宏。 在下面的原理图代码中：

• N = 整个数据集中的行数，
• M = 分割后的文件总数，
• i = 执行包装宏的每个“块”（最多三个），
• n = 初始数据集中的每一行，
• m = 拆分后每个文件的编号标签（与拆分文件的名称同构）。

示意图：

For i = 1 to 3, Start new block-wise Macro
     Start Original Macro with the original aim of splitting (N) rows into (M) files
     .....
     End Original Macro when m=M/3 (instead of when m=M)
End of a particular block corresponding to the application of the wrapper Macro

这是原始宏（请注意，上面的原理图变量名称与实际宏中的名称不同）：

Public Sub SplitToFiles() 
   
    ' MACRO SplitToFiles
    ' Last update: 2019-05-28
    ' Author: mtone
    ' Version 1.2
    ' Description:
    ' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
    '
    ' Note: Values in the column should be unique or sorted.
    '
    ' The following cells are ignored when delimiting sections:
    ' - blank cells, or containing spaces only
    ' - same value repeated
    ' - cells containing "total"
    '
    ' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
    
    Dim osh As Worksheet                         ' Original sheet
    Dim iRow As Long                             ' Cursors
    Dim iCol As Long
    Dim iFirstRow As Long                        ' Constant
    Dim iTotalRows As Long                       ' Constant
    Dim iStartRow As Long                        ' Section delimiters
    Dim iStopRow As Long
    Dim sSectionName As String                   ' Section name (and filename)
    Dim rCell As Range                           ' current cell
    Dim owb As Workbook                          ' Original workbook
    Dim sFilePath As String                      ' Constant
    Dim iCount As Integer                        ' # of documents created
    
    iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
    iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 2, , , , , 1)
    iFirstRow = iRow
    
    Set osh = Application.ActiveSheet
    Set owb = Application.ActiveWorkbook
    iTotalRows = osh.UsedRange.Rows.Count
    sFilePath = Application.ActiveWorkbook.Path
    
    If Dir(sFilePath + "\Split", vbDirectory) = "" Then
        MkDir sFilePath + "\Split"
    End If
    
    'Turn Off Screen Updating  Events
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Do
        ' Get cell at cursor
        Set rCell = osh.Cells(iRow, iCol)
        sCell = Replace(rCell.Text, " ", "")
    
        If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
            ' Skip condition met
        Else
            ' Found new section
            If iStartRow = 0 Then
                ' StartRow delimiter not set, meaning beginning a new section
                sSectionName = rCell.Text
                iStartRow = iRow
            Else
                ' StartRow delimiter set, meaning we reached the end of a section
                iStopRow = iRow - 1
    
                ' Pass variables to a separate sub to create and save the new worksheet. fileFormat = 51 corresponds to .xlsx extension
                CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, 51
                iCount = iCount + 1
    
                ' Reset section delimiters
                iStartRow = 0
                iStopRow = 0
    
                ' Ready to continue loop
                iRow = iRow - 1
            End If
        End If
    
        ' Continue until last row is reached
        If iRow < iTotalRows Then
            iRow = iRow + 1
        Else
            ' Finished. Save the last section. fileFormat = 51 corresponds to .xlsx extension
            iStopRow = iRow
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, 51
            iCount = iCount + 1
    
            ' Exit
            Exit Do
        End If
    Loop
    
    'Turn On Screen Updating  Events
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox Str(iCount) + " documents saved in " + sFilePath
        
End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
    
    Dim rngRange As Range
    Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
    rngRange.Select
    rngRange.Delete
    
End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
    Dim ash As Worksheet                         ' Copied sheet
    Dim awb As Workbook                          ' New workbook
    
    ' Copy bookXlFileFormat
    osh.Copy
    Set ash = Application.ActiveSheet
    
    ' Delete Rows after section
    If iTotalRows > iStopRow Then
        DeleteRows ash, iStopRow + 1, iTotalRows
    End If
    
    ' Delete Rows before section
    If iStartRow > iFirstRow Then
        DeleteRows ash, iFirstRow, iStartRow - 1
    End If
    
    ' Select left-topmost cell
    ash.Cells(1, 1).Select
    
    ' Clean up a few characters to prevent invalid filename
    sSectionName = Replace(sSectionName, "/", " ")
    sSectionName = Replace(sSectionName, "\", " ")
    sSectionName = Replace(sSectionName, ":", " ")
    sSectionName = Replace(sSectionName, "=", " ")
    sSectionName = Replace(sSectionName, "*", " ")
    sSectionName = Replace(sSectionName, ".", " ")
    sSectionName = Replace(sSectionName, "?", " ")
    sSectionName = Strings.Trim(sSectionName)
    
    ' Save in same format as original workbook
    '
    ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
    
    ' Close
    Set awb = ash.Parent
    awb.Close SaveChanges:=False
End Sub

Answer 1

要使您的程序分块工作，您需要通过采用参数使SplitToFiles更通用：

Public Sub SplitToFiles(ByVal StartRow As Long, ByVal EndRow As Long, ByVal SplitByColumn As Long)
    ' declare variables …

    iCol = SplitByColumn
    iRow = StartRow

然后确保将StartRow作为开始的行并退出循环，如果达到行StartRow + AmountOfRows ：

Do While iRow <= EndRow 

然后你可以把它包装成另一个过程：

Public Sub SplitBlocksOfFiles()
    Const MAX_BLOCKS As Long = 3  ' Define the maximum of blocks to perform

    Dim SplitByColumn As Variant
    SplitByColumn = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
    If VarType(SplitByColumn) = vbBoolean And SplitByColumn = False Then Exit Sub  ' User pressed cancel

    Dim HeaderRows As Variant
    HeaderRows = Application.InputBox("How many header rows do we have?)", "Select row", 2, , , , , 1)
    If VarType(HeaderRows) = vbBoolean And HeaderRows = False Then Exit Sub  ' User pressed cancel

    Do
        Dim Block As Variant
        Block = Application.InputBox("Which of the " & MAX_BLOCKS  & " blocks do you want to perform now?)", "Select row", 2, , , , , 1)
        If VarType(Block) = vbBoolean And Block = False Then Exit Sub  ' User pressed cancel
    Loop While CLng(Block) > MAX_BLOCKS Or CLng(Block) < 1 ' If invalid number ask again
        

    Dim TotalAmountOfRows As Long
    TotalAmountOfRows =  ' ToDo: determine the amount of rows
    
    ' calculate start and end row for the block
    Dim StartRow As Long
    Dim EndRow As Long
   
    If Block = 1 Then  ' first block
        StartRow = HeaderRows + 1
        EndRow = StartRow + AmountOfRows - HeaderRows - 1
    ElseIf Block = MAX_BLOCKS Then  ' last block
        StartRow = AmountOfRows * (Block - 1) + 1
        EndRow = TotalAmountOfRows
    Else  ' all other blocks
        StartRow = AmountOfRows * (Block - 1) + 1
        EndRow = StartRow + AmountOfRows - 1
    End If

    ' run the splitting for the block only
    SplitToFiles StartRow, EndRow, CLng(SplitByColumn)
End Sub

所以对于TotalAmountOfRows = 60002总行数和HeaderRows = 1这将处理以下块/行

堵塞	起始行	行尾
1	2	20000
2	20001	40000
3	40001	60002