Erstellen von Adressetiketten anhand einer Tabelle

Beispielcode bereitgestellt von:Bill Jelen, MrExcel.com

Im folgenden Codebeispiel wird eine Adressliste mit jeweils einer Adresse pro Zeile in ein anderes Arbeitsblatt kopiert und so angepasst, dass die Adressen auf druckbare Adressetiketten passen. Die Arbeitsmappe muss zwei Arbeitsblätter enthalten, eins dem Namen „Adressen“ und eins mit dem Namen „Etiketten“. Die Adressen im Arbeitsblatt „Adressen“ müssen wie folgt formatiert sein: eine Adresse pro Zeile, Name in Spalte A, Adresszeile 1 in Spalte B, Adresszeile 2 in Spalte C, und Ort, Bundesland, Land/Region und Postleitzahl in Spalte D. Die Adressen werden neu angeordnet und in das Arbeitsblatt „Etiketten“ kopiert.

Sub CreateLabels() 
    ' Clear out all records on Labels 
    Dim LabelSheet As Worksheet 
    Set LabelSheet = Worksheets("Labels") 
    LabelSheet.Cells.ClearContents 
 
    ' Set column width for labels 
    LabelSheet.Cells(1, 1).ColumnWidth = 35 
    LabelSheet.Cells(1, 2).ColumnWidth = 36 
    LabelSheet.Cells(1, 3).ColumnWidth = 30 
     
    ' Loop through all records 
    Dim AddressSheet As Worksheet 
    Set AddressSheet = Worksheets("Addresses") 
    FinalRow = AddressSheet.Cells(65536, 1).End(xlUp).Row 
     
    If FinalRow > 1 Then 
        NextRow = 1 
        NextCol = 1 
        For i = 2 To FinalRow 
            ' Set up row heights 
            If NextCol = 1 Then 
                LabelSheet.Cells(NextRow, 1).Resize(4, 1).RowHeight = 15.25 
                LabelSheet.Cells(NextRow + 4, 1).RowHeight = 13.25 
            End If 
         
            ' Put the Name in row 1 
            ThisRow = NextRow 
            LabelSheet.Cells(ThisRow, NextCol).Value = AddressSheet.Cells(i, 1) & "   " & AddressSheet.Cells(i, 7) 
             
            ' Put the Address Line 1 in row 2 
            If AddressSheet.Cells(i, 2).Value > "" Then 
                ThisRow = ThisRow + 1 
                LabelSheet.Cells(ThisRow, NextCol).Value = AddressSheet.Cells(i, 2) 
            End If 
             
            ' Put the Address Line 2 in row 3 
            If AddressSheet.Cells(i, 3).Value > "" Then 
                ThisRow = ThisRow + 1 
                LabelSheet.Cells(ThisRow, NextCol).Value = AddressSheet.Cells(i, 3) 
            End If 
             
            ' Put the City, State, Country/Region and Postal code in row 4 
            If AddressSheet.Cells(i, 4).Value > "" Then 
                CitySt = AddressSheet.Cells(i, 4) 
            End If 
            ThisRow = ThisRow + 1 
            LabelSheet.Cells(ThisRow, NextCol).Value = CitySt 
             
            ' Update the row and column for the next label 
            If NextCol = 1 Then 
                NextCol = 2 
            ElseIf NextCol = 2 Then 
                NextCol = 3 
            Else 
                NextCol = 1 
                NextRow = NextRow + 5 
            End If 
         
        Next i 
         
        LabelSheet.Activate 
    Else 
        MsgBox "No records match the criteria" 
    End If 
End Sub

Über den Autor

MVP Bill Jelen hat über zwei Dutzend Bücher über Microsoft Excel verfasst. Er ist regelmäßiger Gast auf TechTV mit Leo Laporte und hostet MrExcel.com, ein Forum mit über 300.000 Fragen und Antworten zu Excel.

Support und Feedback

Haben Sie Fragen oder Feedback zu Office VBA oder zu dieser Dokumentation? Unter Office VBA-Support und Feedback finden Sie Hilfestellung zu den Möglichkeiten, wie Sie Support erhalten und Feedback abgeben können.