Option Explicit
Public Sub SplitWorksheetByStoreID()
If ActiveSheet Is Nothing Then Exit Sub
If Not TypeOf ActiveSheet Is Excel.Worksheet Then Exit Sub
If vbCancel = MsgBox("Die Daten, auf dem Aktiven Blatt, werden nun nach der 'store_id' aufgesplittet.", _
vbQuestion Or vbOKCancel Or vbDefaultButton2) _
Then
Exit Sub
End If
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim wksDst As Excel.Worksheet
Dim i As Long, j As Long
Dim blnError As Boolean
With Range("A1").CurrentRegion
Call .Sort(Key1:=.Cells(1, "D"), Order1:=xlAscending, Header:=xlYes)
i = 2
Do Until i > .Rows.Count
j = i
Do While .Cells(i, "D") = .Cells(j + 1, "D")
j = j + 1
Loop
If WorksheetExists(.Cells(i, "D").Text) Then
Set wksDst = Worksheets(.Cells(i, "D").Text)
Call wksDst.UsedRange.Delete
ElseIf Not wksDst Is Nothing Then
Set wksDst = ThisWorkbook.Worksheets.Add(After:=wksDst)
wksDst.Name = .Cells(i, "D").Text
Else
Set wksDst = ThisWorkbook.Worksheets.Add(After:=.Worksheet)
wksDst.Name = .Cells(i, "D").Text
End If
Call Union(.Rows(1), .Worksheet.Range(.Rows(i), .Rows(j))).Copy
With wksDst.Range("A1")
Call .PasteSpecial(xlPasteColumnWidths)
Call .PasteSpecial(xlPasteValuesAndNumberFormats)
End With
On Error Resume Next
Call GAForm
blnError = blnError Or CBool(Err.Number)
On Error GoTo ErrHandler
i = j + 1
Loop
Call .Worksheet.Activate
End With
If Not blnError Then
Call MsgBox("Vorgang erfolgreich abschlossen.", _
vbInformation, _
"Erfolg")
Else
Call MsgBox("Vorgang abschlossen." & vbNewLine & _
"Während der Formatierung traten ein oder mehrere Fehler auf.", _
vbExclamation, _
"Erfolg")
End If
SafeExit:
Application.CutCopyMode = False
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
Call MsgBox(Err.Description, _
vbCritical, _
"Fehler " & Err.Number)
GoTo SafeExit
End Sub
Private Sub GAForm()
Rows(1).ClearContents
With Cells(3, 2).CurrentRegion
With .Offset(-1, 0).Resize(.Rows.Count + 2)
.Cells(1, 1).Value = 1
.Cells(1, 1).Copy
.SpecialCells(xlCellTypeConstants, 2).PasteSpecial xlPasteValues, operation:=xlMultiply
.Rows(1).Value = Array("Datum", "Code", "Wert")
.Columns(1).NumberFormat = "DD.MM.YYYY hh:mm"
.Cells(.Rows.Count, 1).Value = "Summe"
.Cells(.Rows.Count, 3).FormulaR1C1 = "=Sum(R[-" & .Rows.Count - 2 & "]C:R[-1]C)"
.BorderAround Weight:=xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Rows(1).Font.Bold = True
.Rows(.Rows.Count).Font.Bold = True
.Cut Destination:=Cells(5, 1)
Columns("A:A").EntireColumn.AutoFit
ActiveWindow.DisplayGridlines = False
Columns("B:B").EntireColumn.AutoFit
Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "#,##0.00 $"
Rows("4:4").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
End With
End Sub
Private Function WorksheetExists(Name As String, Optional ByVal Workbook As Excel.Workbook) As Boolean
If Workbook Is Nothing Then Set Workbook = ActiveWorkbook
On Error Resume Next
WorksheetExists = Not (Workbook.Worksheets(Name) Is Nothing)
End Function