☰

Wie kann ich ein Excel-Arbeitsblatt basierend auf der Datumsspalte in mehrere Dateien aufteilen?

tag-icon • tag-icon microsoft-excel vba macros
Wie kann ich ein Excel-Arbeitsblatt basierend auf der Datumsspalte in mehrere Dateien aufteilen?

Ich muss ein Arbeitsblatt mit 10.000 Zeilen basierend auf den Daten in Spalte D in mehrere Excel-Dateien aufteilen. Die Datei hat 9 Spalten (A:I). Die Daten in Spalte D sind derzeit als TT/MM/JJJJ formatiert. Ich möchte die Datei nur in MMM/JJJJ aufteilen, damit weniger Dateien vorhanden sind. Hier ist mein bisheriger Code. Er teilt das Arbeitsblatt in mehrere Dateien auf, aber wenn ich die Dateien öffne, wurde nur die Kopfzeile kopiert, nicht die Daten für den entsprechenden Monat und das entsprechende Jahr.

Wie kann ich alle für MMM/JJJJ relevanten Daten in Spalte D kopieren und einfügen und wie kann ich alle aufgeteilten Dateien in einem bestimmten Ordner wie diesem speichern? 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

Antwort1

Die Hauptsache war, zu ersetzen

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

mit

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

Aber ich habe weitere Änderungen vorgenommen, um das Kopieren und Einfügen etwas schneller zu machen. Als Randbemerkung: Einfügen ist keine schnelle Option, Sie könnten so etwas tun wie TargetCell.Value = SourceCell.Value(in diesem Fall werden nur Werte übertragen).

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

Antwort2

Sub SplitData() ' ' SplitData-Makro

Dim objWorksheet als Excel.Worksheet Dim nLastRow als Integer, nRow als Integer, nNextRow als Integer Dim strColumnValue als String Dim objDictionary als Objekt Dim varColumnValues ​​als Variante Dim varColumnValue als Variante Dim objExcelWorkbook als Excel.Workbook Dim objSheet als Excel.Worksheet Dim i als Long Dim FPath als String FPath = Application.ActiveWorkbook.Path

Dim aCol As String aCol = "A"

Bei Fehler GoTo err1

Mit Anwendung .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False Ende mit

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

Setzen Sie objDictionary = CreateObject("Scripting.Dictionary")

Für nRow = 2 bis nLastRow

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

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

Nächste

varColumnValues ​​= objDictionary.Schlüssel

Für i = LBound(varColumnValues) Nach 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)

Nächste

err1: Mit Anwendung .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True Ende mit

End Sub

Funktion CheckDir(Pfad als String)

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

Endfunktion

verwandte Informationen