☰

如何根據日期列將一個 Excel 工作表拆分為多個文件？

tag-icon • tag-icon microsoft-excel vba macros
如何根據日期列將一個 Excel 工作表拆分為多個文件？

我需要根據 D 列中的日期將一個包含 10,000 行的工作表拆分為多個 Excel 文件。 D 欄上的日期目前格式為 DD/MM/YYYY。我只想將文件拆分為 MMM/YYYY，這樣文件就會更少。到目前為止，這是我的程式碼，它將工作表拆分為多個文件，但是當我打開文件時，僅複製了標題，而不是相關月份和年份的資料。

如何複製並貼上與 D 列中的 MMM/YYYY 相關的所有資料以及如何將所有分割文件保存到像這樣的特定資料夾中？ C：\常規\倫敦\客戶

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 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 FPath As String 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

結束功能

相關內容