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
With ActiveSheet.UsedRange.CurrentRegion
If .Columns.Count < 4 Then
Call MsgBox("Keine Daten vorhanden.", vbExclamation)
GoTo SafeExit
End If
If .Cells(2, 4).Value = WorksheetFunction.Average(.Columns(4)) Then
Call MsgBox("Falsches Blatt aktiv.", vbExclamation)
GoTo SafeExit
End If
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
Call GAForm(wksDst)
i = j + 1
Loop
Call .Worksheet.Activate
End With
Call MsgBox("Vorgang erfolgreich abschlossen.", _
vbInformation, _
"Erfolg")
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(Worksheet As Excel.Worksheet)
Dim rng As Excel.Range
Set rng = Worksheet.UsedRange.CurrentRegion
If rng.Rows.Count = 1 _
Then Exit Sub
If Not ActiveSheet Is Worksheet _
Then Worksheet.Activate
With rng.Resize(rng.Rows.Count + 1)
With rng.Rows(1)
Call .Clear
.Font.Bold = True
.Resize(ColumnSize:=3).Value = Array("Datum", "Code", "Wert")
End With
With .Rows(.Rows.Count)
.Font.Bold = True
.Cells(1).Value = "Summe"
.Cells(3).NumberFormat = "#,##0.00 $"
.Cells(3).Formula = "=SUM(R[-1]C:R[-" & rng.Rows.Count - 1 & "]C)"
End With
.Columns(1).NumberFormat = "dd.mm.yyyy hh:mm"
.Columns(3).NumberFormat = "#,##0.00 $"
Call .Columns(2).AutoFit
.Borders.LineStyle = XlLineStyle.xlContinuous
.Borders.Weight = XlBorderWeight.xlThin
End With
ActiveWindow.DisplayGridlines = False
Call rng.Resize(RowSize:=4).Insert(xlShiftDown)
Call rng.Cells(1, 1).Select
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