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

PS: In der GAForm kann es zu Fehlern kommen (bedingt durch den Einsatz von SpecialCells).