☰

根据日期列将 Excel 电子表格拆分为单独的文件

tag-icon • tag-icon microsoft-excel vba
根据日期列将 Excel 电子表格拆分为单独的文件

我有一个 Excel，其中有很多行 20,000+，我想根据创建日期（仅日期，没有时间）进行拆分并保存为单独的文件。

该文件如下所示：
例子

有人能帮我吗？我尝试更改在此网站上找到的一些 VBA 代码，但遇到了无法解决的错误。

答案1

感谢 Shirley Zhang。
原文来自：（datanumen.com/blogs/2-fast-means-to-split-an-excel-worksheets-contents-into-multiple-workbooks-based-on-a-specific-column) 由我编辑。

由于创建、编辑和保存工作簿，计算 20,000 多行需要很长时间。可能超过 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

    Dim aCol As String
    aCol = "G" '<- Change Source-Column here

    On Error GoTo err1
     'Speed up a little bit
     With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
     End With

    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row

    Set objDictionary = CreateObject("Scripting.Dictionary")

     For nRow = 2 To nLastRow
        'Get the specific Column
        'Here my instance is "B" column
        'You can change it to your case

        'strColumnValue = objWorksheet.Range("B" & nRow).Value
        strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "mm_dd_yyyy") '<- Set the filter and filename

        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next

    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(aCol & 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:I").AutoFit 
            End If

        Next

        objExcelWorkbook.SaveAs (CStr(varColumnValue)) 

   Next

err1:
     'Restore slow but necessary settings
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
     End With

End Sub

相关内容