Option Explicit

Sub Schleife()
'
'******************************************************************************
' Name : Schleife / erstellt : 09.12.2014 / 16:23 / Sub
'------------------------------------------------------------------------------
'
' bezogen auf Nachricht vom 08.12.2014 12:17:34
'
'******************************************************************************
'
Const BEGINN_H As String = "H4"     'steht "Platzierung"
Const NAME_D As String = "D16"      'wird Name gedruckt
Const PINS_C As String = "C26"      'ditto  Gebu-Kind gedruckt
Const PLATZ_B As String = "B28"     'ditto Platzierung gedruckt
Const DATUM_C As String = "C45"     'ditto Datum gedruckt - wenn heute gewünscht
Const MANAGER_F As String = "F45"   'ditto - wenn
'die Besonderheit
Const GEBU_KIND As String = "C22"
Const GEBU_NAME As String = "I1"
' wenn erwünscht
Const N_MANAGER As String = "SuperMario"


Dim c As Range
Set c = Range(BEGINN_H).Offset(1)               'ab hier beginnt Platz - Nr.

Do                                              'Schleife

   c.Copy Destination:=Range(PLATZ_B)           'Platz nach Platz
   c.Offset(, 1).Copy Destination:=Range(PINS_C) 'Pins nach Pins
   c.Offset(, 2).Copy Destination:=Range(NAME_D) 'Name nach Name
   'Besonderheit
   Range(GEBU_KIND).Value = Range(GEBU_NAME)
   If Range(NAME_D).Value = Range(GEBU_NAME) Then _
      Range(GEBU_KIND).Value = ""
   'wenn erwünscht
   'Range(MANAGER_F).Value = N_MANAGER
   'ditto - wenn erwünscht
   'Range(DATUM_C).Value = Date     'aktuell (heute)
   
   '*****************************************************************
   'Druckbefehl
    'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
   '*****************************************************************
   
   Set c = c.Offset(1)                 ' 1 nach unten
Loop Until c.Value = ""                'bis Zelle leer

End Sub