☰

如何根据日期列将一个 Excel 工作表拆分为多个文件？

tag-icon • tag-icon microsoft-excel vba macros
如何根据日期列将一个 Excel 工作表拆分为多个文件？

我需要根据 D 列中的日期将包含 10,000 行的工作表拆分为多个 Excel 文件。该文件有 9 列（A:I）。D 列上的日期当前格式为 DD/MM/YYYY。我只想将文件拆分为 MMM/YYYY，这样文件就更少了。这是我到目前为止的代码，它将工作表拆分为多个文件，但当我打开文件时，只复制了标题，而不是相关月份和年份的数据。

我如何复制并粘贴 D 列中与 MMM/YYYY 相关的所有数据以及如何将所有拆分文件保存到特定文件夹中（例如此文件夹）？C:\General\London\Clients

Sub SplitData()
'
' SplitData Macro

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 = "D"

On Error GoTo err1

 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 = 1 To nLastRow

    strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy")

    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)


    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 = 1 To nLastRow
        If CStr(objWorksheet.Range(aCol & nRow).Value) = CStr(varColumnValue) Then

           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:
     With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
     End With

End Sub

答案1

最重要的是更换

If CStr(objWorksheet.Range(aCol & nRow).Value) = CStr(varColumnValue) Then

和

If Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy") = varColumnValue Then

但我做了更多更改，以便更快地完成复制粘贴。顺便说一句，粘贴不是一个快速选项，您可以执行类似操作TargetCell.Value = SourceCell.Value（在这种情况下，只会传输值）。

Sub SplitData()
  '
  ' SplitData Macro

  Dim objWorksheet As Excel.Worksheet
  Dim nLastRow As Integer, nRow As Integer, 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 i As Long

  Dim aCol As String
  aCol = "D"

  On Error GoTo err1

  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

    strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy")

    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)

    Set objExcelWorkbook = Excel.Application.Workbooks.Add

    Set objSheet = objExcelWorkbook.Sheets(1)
    objSheet.Name = objWorksheet.Name

    objSheet.Rows(1).Value = objWorksheet.Rows(1).Value
    objWorksheet.Rows(1).Copy objSheet.Rows(1)

    nNextRow = 2
    For nRow = 1 To nLastRow
      If Format(objWorksheet.Range(aCol & nRow).Value, "Report_mmm_yyyy") = varColumnValue Then
        objWorksheet.Rows(nRow).Copy objSheet.Rows(nNextRow)
        nNextRow = nNextRow + 1
      End If
    Next
    objSheet.Columns("A:I").AutoFit
    ' Closing the workbook with changes saved
    objExcelWorkbook.Close True, CStr(varColumnValue)

  Next

err1:
  With Application
   .ScreenUpdating = True
   .Calculation = xlCalculationAutomatic
   .EnableEvents = True
  End With

End Sub

答案2

Sub SplitData() ' ' SplitData 宏

Dim objWorksheet 作为 Excel.Worksheet Dim nLastRow 作为整数，nRow 作为整数，nNextRow 作为整数 Dim strColumnValue 作为字符串 Dim objDictionary 作为对象 Dim varColumnValues 作为变量 Dim varColumnValue 作为变量 Dim objExcelWorkbook 作为 Excel.Workbook Dim objSheet 作为 Excel.Worksheet Dim i 作为 Long Dim FPath 作为字符串 FPath = Application.ActiveWorkbook.Path

Dim aCol As String aCol =“A”

出错时转到 err1

使用应用程序 .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False 结束

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

设置 objDictionary = CreateObject("Scripting.Dictionary")

对于 nRow = 2 到 nLastRow

strColumnValue = Format(objWorksheet.Range(aCol & nRow).Value, "mmm_yyyy")

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

下一个

varColumnValues = objDictionary.Keys

对于 i = LBound(varColumnValues) 到 UBound(varColumnValues) varColumnValue = varColumnValues(i)

Set objExcelWorkbook = Excel.Application.Workbooks.Add

Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name

objSheet.Rows(1).Value = objWorksheet.Rows(1).Value
objWorksheet.Rows(1).Copy objSheet.Rows(1)

nNextRow = 2
For nRow = 1 To nLastRow
  If Format(objWorksheet.Range(aCol & nRow).Value, "mmm_yyyy") = varColumnValue Then
    objWorksheet.Rows(nRow).Copy objSheet.Rows(nNextRow)
    nNextRow = nNextRow + 1
  End If
Next
objSheet.Columns("A:K").AutoFit
CheckDir (FPath & "\" & varColumnValue)
objExcelWorkbook.SaveAs FPath & "\" & varColumnValue & "\" & "Report.xlsx"
' Closing the workbook with changes saved
objExcelWorkbook.Close True, CStr(varColumnValue)

下一个

err1：使用应用程序 .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True 结束

子目录结束

函数 CheckDir（路径作为字符串）

If Dir(Path, vbDirectory) = "" Then
    MkDir (Path)
End If

结束函数

相关内容