Option Explicit
Sub SplitDataSheet()
Dim lRow As Long, lCol As Integer, BlockGroesse As Integer
Dim AnzNullen As Byte, Nullen As String
Dim rngZeile1 As Range, rngBlock As Range, Block As Integer
Dim ZeBlockS As Long, ZeBlockE As Long, AnzBlocks As Integer
Dim DstPath As String, DstName As String, DstFileName As String
Dim wksSrc As Worksheet, rng2Copy As Range, DateiFormat As Variant
Dim strSpalte As String
Dim strBereich As String
Dim AnzahlWerte As String
Set wksSrc = ActiveSheet
Dim objDict, i As Long, AnzahlMatnr As Long
Set wksSrc = ActiveSheet
Set objDict = CreateObject("Scripting.Dictionary")
With wksSrc
For i = 1 To .Cells(Rows.Count, 3).End(xlUp).Row
If Not objDict.exists(.Cells(i, 3).Value) Then
Call objDict.Add(.Cells(i, 3).Value, Empty)
AnzahlMatnr = AnzahlMatnr + 1
End If
Next
AnzahlMatnr = AnzahlMatnr - 1
MsgBox AnzahlMatnr & " Einträge"
Set wksSrc = ActiveSheet
strBereich = "A1:AJ1048576"
strSpalte = "C"
Range(strBereich).Sort _
Key1:=Range(strSpalte & "1"), Order1:=xlAscending, _
Header:=xlYes
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
BlockGroesse = 48
Set wksSrc = ActiveSheet
DateiFormat = xlWorkbookNormal
If lRow < 2 Then Exit Sub
On Error GoTo ErrorHandler
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
AnzBlocks = WorksheetFunction.RoundUp((AnzahlMatnr) / BlockGroesse, 0)
AnzNullen = Len(CStr(AnzBlocks))
Nullen = WorksheetFunction.Rept(0, AnzNullen)
DstPath = "C:\Users\baumann\Desktop\Auswertung Kristian\Splits"
DstName = "_Block_"
MsgBox AnzBlocks
With wksSrc
Set rngZeile1 = .Range(.Cells(1, 1), .Cells(1, lCol))
For Block = 1 To AnzBlocks
DstFileName = DstPath & DstName & Format(Block, Nullen)
ZeBlockS = (Block - 1) * BlockGroesse + 2
ZeBlockE = WorksheetFunction.Min(ZeBlockS + BlockGroesse - 1, lRow)
Set rng2Copy = Union(rngZeile1, .Range(.Cells(ZeBlockS, 1), .Cells(ZeBlockE, lCol)))
rng2Copy.Copy
Workbooks.Add
With ActiveSheet
.Paste
.Cells(1, 1).Select
End With
With ActiveWorkbook
.SaveAs Filename:=DstFileName, FileFormat:=DateiFormat
.Close SaveChanges:=True
End With
Next Block
End With
ErrorHandler:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
If Err.Number = 0 Then
MsgBox "Aufgabe erledigt!", vbInformation, "Ohne Fehler"
Else
MsgBox "Beendet mit Fehler Nr.: " & Err.Number & vbCrLf _
& Err.Description & vbCrLf _
& "Bitte prüfen Sie das Ergebnis!", vbCritical, "Fehler"
End If
End With
End Sub