Nun,

mit meinen Patienten - Adressdaten klappt der Code, ich benutze die Spalte Ort = "PLZ Ortsname" und trenne nach Monat und PLZ

Option Explicit

'Mappe mit den 12 Tabellenblättern inkl. Daten durchlaufen und verteilen

Sub TestIt()
Dim lngMonat As Long          'Monatszähler
Dim strtbName As String       'Kurzname dazu
Dim oWsh As Excel.Worksheet   'Arbeitsblatt
Dim flag As Boolean           'Hinweis

Dim x As Long, z As Long      'Zähler
Dim arrOrt() As String        'Ort mit Zusatz Leerzeichengetrennt
Dim strOrt As String          'Ort wo Tabellenname
Dim oWSO As Excel.Worksheet   'TabellenOrt
Dim sz As Long                'Zähler dazu

On Error GoTo fail
Application.ScreenUpdating = False
   'Über das Jahr - alle Monate
   For lngMonat = 1 To 12
      'Achtung lokale Namen - März etc.
      strtbName = Left(MonthName(lngMonat), 3)
      'Monatstabelle vorhanden, sonst Abbruch
      flag = False
      Set oWsh = Sheets(strtbName)
      'in der Monatstabelle
      With oWsh
         'von Zeile 2 bis Ende
         z = .Cells(.Rows.Count, 1).End(xlUp).Row  'letzte Zeile
         For x = 2 To z                            'Überschrift
            'Tabellenname wohin ...
            arrOrt = Split(.Cells(x, 1).Formula, " ")
            strOrt = arrOrt(0)                     'Tabellenname wohin ...
            'nicht vorhanden, dann anlegen
            flag = True
            Set oWSO = Sheets(strOrt)
            sz = oWSO.Cells(Rows.Count, 1).End(xlUp).Row + 1 'letzte Zeile Ziel
            'Zieltabelle Spalte 1
            oWSO.Cells(sz, 1).Value = .Name
            'Rest ab Spalte 2 kopieren
            .Range(.Cells(x, 1), .Cells(x, 4)).Copy _
               Destination:=oWSO.Cells(sz, 2)
         Next x
      End With
   Next lngMonat

fail:
Select Case Err.Number
   Case 0
   Case 9
      If flag = True Then
         'Neuanlage
         Sheets.Add after:=Sheets(Sheets.Count)
         ActiveSheet.Name = strOrt
         'mit Überschrift(en)
         ActiveSheet.Cells(1, 1).Value = "aus Monat"
         ActiveSheet.Cells(1, 2).Value = oWsh.Cells(1, 1).Value
         'usw.
         Resume
      Else
         MsgBox "Monatstabellen unvollständig!", vbOKOnly Or vbCritical, "Abbruch"
         End
      End If
      '
   Case Else
End Select
Application.ScreenUpdating = True
End Sub