Werte aus Tabellenbereich in andere Tabelle überge
06.05.2019 14:27:23
Erwin
ich möchte automatisiert eine Telefon-Nebenstellenliste erstellen. Dazu bekomme ich von einer DB die nötigen Daten per Daten-Import. In Spalte A stehen die Abteilungen, in B die Nebenstellen und in C die Namen der Kollegen. Das ist die Tabelle qry_Telefonliste.
Aus dieser möchte ich dann in die Tabelle Nebenstellenverzeichnis ab Zeile 14 pro Abt. die Nummern und Namen untereinander schreiben lassen. Die Abteilungen selber stehen nebeneinander, also in A14 und darunter die Mitarbeiter der Abt1, in C14 und darunter die Mitarbeiter der Abt.2 usw.
Folgenden Code habe ich mir zusammengebastelt, der auch (fast) funktioniert:
Sub nebenstellen_Neu()
'Suchbegriffe definieren
sb1 = "Abt1"
sb2 = "Abt2"
usw.
'Quelle definieren
qtab = "qry_Telefonliste" 'Quelldaten
qspalte = "A" 'Quellspalte, in der gesucht wird
spaltenanzahl = 2 'Anzahl daneben liegender Spalten, aus denen der Wert übertragen werden soll
'Ziel definieren
ztab = "Nebenstellenverzeichnis" 'Zieltabelle
zz = 14 'Übertrag aller Daten ab dieser Zeile
zsAbt1 = "A" 'Übertrag der Daten für Abt1 in dieser Spalte
zsAbt2 = "C" 'Übertrag der Daten für Abt2 in dieser Spalte
zsAbt3 = "E" 'Übertrag der Daten für Abt3 in dieser Spalte
...usw
'Allgemeine Definition
Set q = Worksheets(qtab)
Set Z = Worksheets(ztab)
zzeile = zz 'Startzeile in der Zieldatei
'Abt1
With q.Columns(qspalte)
Set gefunden = .Find(sb1, LookIn:=xlValues) 'Suchspalte der Quelldatei durchsuchen
If Not gefunden Is Nothing Then 'nur wenn der Suchbegriff gefunden wurde, nachfolgende _
Schritte durchführen
Do 'für alle Fundstellen
Z.Cells(zzeile, zsAbt1).Resize(1, spaltenanzahl) = gefunden.Offset(0, 1).Resize(1, _
spaltenanzahl).Value 'Werte der Nachbarzellen übertragen
zzeile = zzeile + 1 'Zeilennummer in der Zieltabelle um 1 erhöhen
Set gefunden = .FindNext(gefunden) 'Nächste Fundstelle suchen
Loop Until gefunden sb1 'Solange suchen wie Suchbegriff vorhanden
End If
zzeile = zz
End With
'Abt2
With q.Columns(qspalte)
Set gefunden = .Find(sb2, LookIn:=xlValues) 'Suchspalte der Quelldatei durchsuchen
If Not gefunden Is Nothing Then 'nur wenn der Suchbegriff gefunden wurde, nachfolgende _
Schritte durchführen
Do 'für alle Fundstellen
Z.Cells(zzeile, zsAbt2).Resize(1, spaltenanzahl) = gefunden.Offset(0, 1).Resize(1, _
spaltenanzahl).Value 'Werte der Nachbarzellen übertragen
zzeile = zzeile + 1 'Zeilennummer in der Zieltabelle um 1 erhöhen
Set gefunden = .FindNext(gefunden) 'Nächste Fundstelle suchen
Loop Until gefunden sb2 'Solange suchen wie Suchbegriff vorhanden
End If
zzeile = zz
End With
...usw
End Sub
Die erste With-Anweisung für Abt1 klappt wunderbar, sucht alle Nr. und Namen nach dem Suchbegriff und schreibt diese sauber in das Tabellenblatt Nebenstellenverzeichnis.
Fängt dann auch mit der nächsten Abteilung an und schreibt diese rein, aber
es hört nicht mehr auf! Wenn alle Namen der Abteilung abgearbeitet sind, fängt es wieder von vorne an und es werden wieder alle Namen dieser Abt. untereinander geschrieben. Irgendwie habe ich da eine Dauerschleife. Aber warum, bei der ersten Anweisung gehts ja auch!
Das zweite Problem ist, es werden auch ab und zu Namen ohne Tel-Nr. importiert. Kann ich da noch so eine Art Wenn-Dann-Bedingung einbauen, dass wenn keine Nebenstelle in den Quelldaten angegeben ist der Name auch nicht übernommen werden soll?
Für eine Antwort wäre ich sehr dankbar!
Schöne Grüße
Erwin