Hallo ihr fleissigen Excel Profi ich habe eine umfangreiche Tabelle mit mehreren Spalten, unterteilt in 2 Hälften. Rechts sind "Masterdaten" und und links ein für mich komprimierter "Auszug". Das funktioniert auch ganz gut. Wenn aber die Spaltenüberschriften der "Masterdaten" in einerandern Spalte stehen, muss ich jedesmal das Makro ändern.
Ich möchte nun, dass anstelle der Spalten Bezeichnung (Const von ="AR, .....), die Überschriften
Hallo Namensvetter, nach einigen Korrekturen und Erweiterungen der Listen und der Änderung der Überschrfit in den Masterdaten zu Vor - name und Nach - name bin ich zu folgendem Ergebnis gekommen:
PHP-Code:
Sub Spalten_kopieren() Dim lz01&, i&, ersteZeile Const von = "Stamm,GEN 1,Vor - name,Nach - name,Geburt - Datum,Geburt - Ort,Ehe - Heirat - Datum,Ehe - Heirat - Ort,Tod - Datum,Tod - Ort,Wohnort - Adresse,Wohnort - Ort,Beruf,Quelle" Const nach = "D,E,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL" Dim aVon, aNach ersteZeile = 7 aVon = Split(von, ",") With Sheets(1) For i& = LBound(aVon) To UBound(aVon) aVon(i&) = Val(.Rows(ersteZeile - 1).Find(what:=aVon(i&), lookat:=xlWhole).Column) Next i& aNach = Split(nach, ",") lz01 = Range("BD" & Cells.Rows.Count).End(xlUp).Row For i& = LBound(aVon) To UBound(aVon) .Range(.Cells(ersteZeile, Val(aVon(i&))), .Cells(lz01&, Val(aVon(i&)))).Copy Destination:=.Range(aNach(i) & ersteZeile) Next End With End Sub
Ob das so richtig ist, kannst nur Du rausfinden. Gruß der (auch Martin) AlteDresdner
Hallo ihr fleissigen Helfer, habe nach einigen Versuchen ein lauffähiges Makro hinbekomme. Der Debugg Fehler entstand durch nicht korrekte Überschriften (Makro zu Tabelle). Es kopiert die Spalten korrekt bis auf die Überschrift "Beruf". Da da will es nicht kopieren. Könnte mal jemand drüberschauen und ein Typ geben, was ich falsch mache oder ändern muss. Mit dankbaren Grüssen Martin
Hallo Martin, der Fehler besteht darin, dass die Überschrift Beruf schon im Auszug vorhanden ist, damit findet das ...Find auch diese Spalte. Entweder setzt Du in den Masterdaten eindeutige Überschriften, die nicht im Auszug vorkommen, und sucht dann auch nach denen (z.B. Beruf->Beruf_) oder Du schreibst im Code
PHP-Code:
For i& = LBound(aVon) To UBound(aVon) aVon(i&) = Val(.Rows(ersteZeile - 1).Find(after:=.Cells(ersteZeile - 1, 41), what:=aVon(i&), lookat:=xlWhole).Column)
Das After:=... legt fest, das erst ab Spalte 41 gesucht wird. Dann dürfen auch doppelte Überschriften Master und Auszug vorkommen...
Hallo AlterDresdner (Martin) danke für deine Erklärung und den änderungs Vorschlag. Jetzt funktioniert es wie gewünscht. Danke, dass du geholfen hast. Das ist :35: Eine schöne Woche wüscht dir Martin
Hallo AlterDresdner (Martin) wenn eine Überschrift (ZB. "Stamm") nicht vorkommt, bringt das einen Debugfehler. Wäre es möglich, dass dieser Fehler abgefangen werden kann. Zum Beispiel, wenn "Stamm" nicht vorhanden ist, überspringen und weiter mit nächster Überschrift.
Frage mich, ob es für mein Makro eine bessere Lösung gibt? Wenn ja, wie müsste das Makro aussehen? Wäre es eventuell nicht besser, wenn man alles auftrennen würde? Zum Beispiel: wenn Überschrift "Stamm" vorhanden ist, kopiere die Daten nach Spalte "D", wenn Überschrift fehlt, weiter mit Überschrift "Vornamen" usw. Danke für weitere Hilfe und ein schöner Sonnabend wünscht Martin
Hallo Martin, die Fehlerumgehung ist im folgenden drin (Option base 1 ist wichtig!):
PHP-Code:
Option Explicit Option Base 1 Sub Spalten_kopieren() Dim lz01&, i&, ersteZeile Const von = "Stamm,Vor - name,Nach - name,Geburt - Datum,Geburt - Ort,Ehe - Heirat - Datum,Ehe - Heirat - Ort,Tod - Datum,Tod - Ort,Wohnort - Ort,Wohn - Adresse,Beruf,Notiz,Quelle 2" Const nach = "D,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM" Dim aVon, aNach, aTemp, aTempnach, anzCopy As Long, erg ersteZeile = 7 aTemp = Split(von, ",") aTempnach = Split(nach, ",") ReDim aVon(1) ReDim aNach(1) anzCopy = 0 With Sheets(1) For i& = LBound(aTemp) To UBound(aTemp) Set erg = .Rows(ersteZeile - 1).Find(after:=.Cells(ersteZeile - 1, 41), what:=aTemp(i&), lookat:=xlWhole) If Not erg Is Nothing Then anzCopy = anzCopy + 1 If anzCopy > UBound(aVon) Then ReDim Preserve aVon(anzCopy) ReDim Preserve aNach(anzCopy) End If aVon(anzCopy) = Val(erg.Column) aNach(anzCopy) = aTempnach(i&) End If Next i& lz01 = Range("BD" & Cells.Rows.Count).End(xlUp).Row For i& = 1 To anzCopy .Range(.Cells(ersteZeile, Val(aVon(i&))), .Cells(lz01&, Val(aVon(i&)))).Copy Destination:=.Range(aNach(i) & ersteZeile) Next End With End Sub
Es wird dann halt nur das kopiert, was da ist. Ob das Ganze der Weisheit letzter Schluß ist? Das Makro wäre ganz überflüssig, wenn man die Aufteilung Stammdaten-Auszug wegläßt und halt die (Auszug-) Daten vorn anordnet und den Rest weiter rechts.
Sub M_snb() sn = Cells(6, 1).CurrentRegion sp = Cells(1, 43).CurrentRegion
For jj = 4 To UBound(sn, 2) If jj < 6 Or jj > 26 Then For j = 2 To UBound(sn) sp(j, IIf(jj < 6, jj - 3, Choose(jj - 25, 13, 14, 17, 16, 24, 25, 19, 44, 43, 41, 34, 47))) = sn(j, jj) Next End If Next
Cells(1, 43).CurrentRegion=sp End Sub
Aber...., wenn das Arbeitsbaltt besser strukturiert ist braucht man diese doppelte Eingabe weder VBA nicht mehr.
19.10.2020, 19:53 (Dieser Beitrag wurde zuletzt bearbeitet: 19.10.2020, 20:00 von luna101.)
Hallo AlteDresdner (Martin), :98: für die Anpassung. Funktioniert :35:
Mit freundlichen Grüssen Martin
PS: Betreff Darstellung, hättest du ein Vorschlag wie es besser wäre? Guten Abend snb, :98: für das Makro. Werde es mal testen und versuchen, zu verstehen, wie das funktioniert. Mit dankbaren Grüssen Martin
PS: "wenn das Arbeitsbaltt besser strukturiert ist braucht man diese doppelte Eingabe weder VBA nicht mehr." Bin für jeden Vorschlag dankbar.
