Tabelle für Etikettendruck optimieren

Hallo alle,
ich habe ein nettes Problem im Angebot: Ich habe eine große Tabelle mit der Struktur wie im Beispiel. Links Namen und Kontaktdaten, rechts Adressen zu den Namen. Es kann vorkommen, dass mehrere Personen dieselbe Adresse haben, das sieht dann so aus wie im Beispiel: Frau Mahlzahn und Jim Knopf hätten also dieselbe Adresse.
Was ich benötige, sind Briefetiketten. D.h. die Tabelle müsste irgendwie so umgebaut werden, dass der Name aus der linken Spalte zur zugehörigen Postadresse in die rechte Spalte gerückt wird. Dann sollte man das m.E. nach über den Seriendruckassistenen leicht machen können (in Word kopiert natürlich).
In der Beispieltabelle müsste also A2 unter B2 eingefügt werden (kopieren oder ausschneiden ist mir egal)
Ich habe ziemlich viele Adressen und die Alternative ist, dass ich alles von Hand abschreibe. Ich würd mich also ziemlich freuen, wenn jemand einen Geistesblitz hat ;-)
Der Link zur Tabelle: https://www.herber.de/bbs/user/57174.xls
nb: ich hab die Daten auch in Word. Wenn jemand da eine Lösung wüsste ist mir auch geholfen...
Tausend Dank für Eure Hilfe und viele Grüße
Sebastian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sebastian,
ich glaube, mit Formeln ist das nicht lösbar, da zu viele verschiedene Kombinationen vorhanden sind.
Deswegen ist wohl hier VBA angebracht:
Option Explicit


Sub Adressen()
Dim LZeile As Double
Dim i As Double
Dim j As Double
Dim BLaenge As Byte
Dim AZeile As Integer
Dim AFeld(0 To 8) As String     'Anzahl der Adressfelder je Adresse
LZeile = Range("A65536").End(xlUp).Row  'Letzte benutzte Zeile in Spalte A
For i = 1 To LZeile
If Cells(i, 1).Interior.ColorIndex  8 Then    'Felder mit Farbe 8 werden übersprungen
If Cells(i, 1)  "" And Left(Cells(i, 1), 9)  "(löschen:" Then    'leere Zeilen und  _
Zeilen mit 'löschen' werden übersprungen
BLaenge = Range("A" & i).End(xlDown).Row - i + 1    'Länge des Adressblockes
If Range("B" & i)  "" And Range("B" & i).End(xlDown).Row - i + 1 > BLaenge Then  _
BLaenge = Range("B" & i).End(xlDown).Row - i + 1  'Korrektur der Blocklänge, wenn Adresslänge mehr Zeilen hat
For j = 1 To BLaenge
If Range("B" & i + j - 1)  "" Then AFeld(j) = Range("B" & i + j - 1)  'Füllen  _
der Adressfelder
Next
AFeld(0) = Range("A" & i)   'erstes Adressfeld = Name
AZeile = Range("D65000").End(xlUp).Row + 1   'erste freie Zeile für Ergebnistabelle
For j = 0 To BLaenge
Cells(AZeile, j + 4) = AFeld(j)     'Ausfüllen der Ergebnistabelle
Next
i = i + BLaenge
End If
End If
Next
End Sub

In deiner letzten Beispieltabelle funzt das soweit. Wenn du den Code auf deine Echt-Tabelle loslässt, musst du aber sicherlich einiges anpassen. Schau dir hierzu alle Stellen an, wo "Range" und "Cells" steht, ob der Code sich in der richtigen Zeile/Spalte bewegt.
Gruß
David

Beliebteste Forumthreads (12 Monate)

Tabelle für Etikettendruck optimieren

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread