Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
VBA - Werte kopieren
30.06.2018 01:19:20
Micha
Ich benötige Hilfe für die Lösung folgender Aufgabenstellung:
Ich möchte immer dann wenn der in der Spalte D, E, F oder G eingetragene Wert im Tabellenblatt "Quelle", dass die Werte aus den Spalten A,D,E,F und G des Tabellenblattes "Quelle" in das Tabellenblatt "Ziel" in die Spalten A und B kopieren.
Die Werte aus der Spalte A des Tabellenblattes "Quelle" sollen dabei in die Spalte A des Tabellenblattes "Ziel" kopiert werden und die zugehörigen Werte aus den Spalten D, E, F und G des Tabellenblattes "Quelle" sollen untereinander in die Spalte B des Tabellenblattes "Ziel" kopiert werden.
Diesen Teil der Aufgabenstellung habe ich bereits in einen VBA-Code eintragen können - siehe beigefügte Beispieltabelle.
Sub DatenKopieren()
Dim Quelle As Worksheet
Dim Ziel As Worksheet
Dim L As Long
Dim i As Long
Set Quelle = ActiveWorkbook.Worksheets("Quelle")
Set Ziel = ActiveWorkbook.Worksheets("Ziel")
For L = 2 To Quelle.UsedRange.Rows.Count
If Quelle.Cells(L, 4).Value  "" Then
i = 1
Do Until Ziel.Cells(i, 1) = ""
i = i + 1
Loop
Ziel.Cells(i, 1).Value = Quelle.Cells(L, 1).Value
Ziel.Cells(i, 2).Value = Quelle.Cells(L, 4).Value
End If
If Quelle.Cells(L, 5).Value  "" Then
i = 1
Do Until Ziel.Cells(i, 1) = ""
i = i + 1
Loop
Ziel.Cells(i, 1).Value = Quelle.Cells(L, 1).Value
Ziel.Cells(i, 2).Value = Quelle.Cells(L, 5).Value
End If
If Quelle.Cells(L, 6).Value  "" Then
i = 1
Do Until Ziel.Cells(i, 1) = ""
i = i + 1
Loop
Ziel.Cells(i, 1).Value = Quelle.Cells(L, 1).Value
Ziel.Cells(i, 2).Value = Quelle.Cells(L, 6).Value
End If
If Quelle.Cells(L, 7).Value  "" Then
i = 1
Do Until Ziel.Cells(i, 1) = ""
i = i + 1
Loop
Ziel.Cells(i, 1).Value = Quelle.Cells(L, 1).Value
Ziel.Cells(i, 2).Value = Quelle.Cells(L, 7).Value
End If
Next L
End Sub

Jetzt kommt jedoch meine Schwierigkeit:
Alle Werte, die bereits einmal vom Tabellenblatt "Quelle" in das Tabellenblatt "Ziel" kopiert wurden, sollen nicht nochmals kopiert werden. Das heißt es sollen immer nur neu eingetragenen Werte aus dem Tabellenblatt "Quelle" in das Tabellenblatt "Ziel" kopiert werden.
Darüber hinaus soll im Tabellenblatt "Ziel" in der Spalte C für alle in die Spalte B kopierten Werte noch der zugehörige Eintrag aus den Zellen D1, E1, F1 bzw. G1 des Tabellenblattes "Quelle" kopiert werden. Dafür habe ich noch keine Lösung...
Die beigfügte Beispieltabelle enthält im Tabellenblatt "Ziel" bereits eine Darstellung für das von mir gewünschte Ergebnis:
https://www.herber.de/bbs/user/122400.xlsm
Viele Grüße
Micha

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Werte kopieren
30.06.2018 10:17:46
Barbaraa
Hi Micha,
Zuerst das leichtere:
"Kaufpreis" kopierst Du mit
Ziel.Cells(i, 3).Value = Quelle.Cells(1, 4).Value
Dann zum Aufbau der Zieltabelle:
Die letzte Zeile findest Du schneller mit:
Ziel.Cells(1,1).end(xldown).row
Dann statt der do-Loop-Schleife eine for-next-Schleife:
For i=1 to Ziel.Cells(1,1).end(xldown).row
...
next i
In der Schleife nach Gleichheiten von Akte und Bemerkung prüfen, also ob Akte übereinstimmen, also:
"Quelle.Cells(L, 1)" = "Ziel.Cells(i, 1)"
und falls ja, dann ob die Spaltenübeschrift mit der Bemerkung übereinstimmt:
"Quelle.Cells(1, 4)" = "Ziel.Cells(i, 3)"
Falls immer noch ja, dann "Exit for".
Nach Verlassen der for-next-Schleife prüfen, ob die Schleife durch Ablauf oder durch Abbruch (exit for) verlassen wurde.
Letzteres ist der Fall, wenn i größer oder gleich Ziel.Cells(1,1).end(xldown).row ist.
Mit einer entsprechenden if-Bedingung die Schreibevorgänge ausführen.
Konnte ich helfen?
So nebenbei:
Wie viele Zeilen und Spalten hat denn Deine Quelle-Datei?
LGB
Anzeige
AW: VBA - Werte kopieren
30.06.2018 10:37:02
hary
Moin
Habe es mit Array nicht so am Hut. Ist fuer mich eher eine Uebung.
Wenn Verbesserungen moeglich sind, die anderen auffallen, bitte Bescheid geben.
Geht bestimmt noch was.;-))
Aber Teste mal:
Sub DatenKopieren2()
Dim myarray()
Dim anzahl As Long, zelle As Range, zeile As Long, letzte As Long
Dim Zellen As Range
Dim wksQ As Worksheet, wksZ As Worksheet
Set wksZ = Worksheets("Ziel")
Set wksQ = Worksheets("Quelle")
For Each Zellen In wksQ.Range("A2:A10")
anzahl = Application.CountA(wksQ.Cells(Zellen.Row, 2).Resize(1, 6)) + 1
If anzahl > 1 Then
If Application.CountIf(wksZ.Columns(1), Zellen) = 0 Then
ReDim myarray(anzahl, anzahl)
zeile = 0
For Each zelle In wksQ.Cells(Zellen.Row, 2).Resize(1, 6)
If zelle  "" Then
myarray(zeile, 0) = wksQ.Cells(zelle.Row, 1)
myarray(zeile, 1) = wksQ.Cells(zelle.Row, zelle.Column)
myarray(zeile, 2) = wksQ.Cells(1, zelle.Column)
zeile = zeile + 1
End If
Next
letzte = wksZ.Cells(Rows.Count, 1).End(xlUp).Row + 1
wksZ.Cells(letzte, 1).Resize(anzahl, 3) = myarray
End If
End If
Next
End Sub

gruss hary
Anzeige
AW: VBA - Werte kopieren
30.06.2018 16:48:14
Micha
Hary,
vielen Dank für deine Lösung, die mir wunderbar gefällt und bei mir auch funktioniert. Nun aber noch zwei Fragen:
1.) Gibt es eine Möglichkeit, dass das System die bereits kopierten Einträge im Tabellenblatt "Ziel" auch noch drauf prüft, ob bei diesen Werten im Tabellenblatt "Quelle" die Werte nachträglich verändert wurden. Wenn ja, dann soll er die bestehenden Werte im Tabellenblatt "Ziel" durch die aktualisierten Werte aus dem Tabellenblatt "Quelle" ersetzen. Wichtig ist jedoch, dass sich die bestehenden Zeilen im Tabellenblatt "Ziel" dadurch nicht noch oben oder unten verschieben sondern nur die aktualisierten Werte ersetzt werden.
Beispiel:
Im Tabellenblatt "Quelle" wird in der Zelle "D2" der Wert nachträglich (also nach dem Kopieren) von 100,50 € auf 200,00 € aktualisiert.
2.) Gibt es eine Möglichkeit, dass immer dann wenn in den bestehenden Zeilen des Tabellenblattes "Quelle" in einer bisher noch nicht ausgefüllten Zeile ein Wert eingetragen wird, dass dieser dann beim nächsten Anstarten des Makros dann entsprechend berücksichtigt wird und in dem Tabellenblatt "Ziel" dann aber ans Ende der bereits bestehenden Einträge, d.h. also in die erste leere Zeile kopiert werden.
Beispiel:
Im Tabellenblatte "Quelle" wird in der Zelle "F2" nach dem Kopieren erstmals ein Wert eingetragen (Zelle "F2" bisher: leer; Zeile "F2" jetzt: 499,99 €).
Für eine erneute Hilfestellnung wäre ich dir sehr dankbar.
https://www.herber.de/bbs/user/122411.xlsm
Viele Grüße
Micha
Anzeige
AW: VBA - Werte kopieren
30.06.2018 10:40:38
Barbaraa
Hi nochmals,
hier nur mal so auf die Schnelle:

Sub DatenKopieren0630()
Dim aTabelle()      As Variant
Dim aListe()        As Variant
'Ausgangsblatt
Dim lZeile          As Long         'Laufende Zeile
Dim lSpalte         As Long         'Laufende Spalte
'Ergebnisblatt
Dim wsListe         As Worksheet    'Ergebnisblatt
Dim lZielZeile      As Long         'Eintragszeile
Set wsListe = Sheets("Ziel")
aTabelle = Sheets("Quelle").Range("A1").CurrentRegion.Value
ReDim aListe(1 To 3, 0)
aListe(1, 0) = "Akte"
aListe(2, 0) = "Betrag"
aListe(3, 0) = "Bemerkung"
For lZeile = 2 To UBound(aTabelle, 1)
For lSpalte = 4 To 7
If aTabelle(lZeile, lSpalte)  "" Then
For lZielZeile = 1 To UBound(aListe, 2)
If aListe(1, lZielZeile) = aTabelle(lZeile, 1) Then
If aListe(3, lZielZeile) = aTabelle(1, lSpalte) Then
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
Exit For
End If
End If
Next lZielZeile
If lZielZeile > UBound(aListe, 2) Then
ReDim Preserve aListe(1 To 3, 0 To lZielZeile)
aListe(1, lZielZeile) = aTabelle(lZeile, 1)
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
End If
End If
Next lSpalte
Next lZeile
With wsListe
.Activate
.Range(Cells(1, 1), _
Cells(1 + UBound(aListe, 2) - LBound(aListe, 2), _
1 + UBound(aListe, 1) - LBound(aListe, 1))) _
= Application.Transpose(aListe)
End With
End Sub
Achtung die Liste in Ziel wird jedesmal gelöscht und neu angelegt, aber superschnell.
Funktioniert das?
LGB
Anzeige
AW: VBA - Werte kopieren
01.07.2018 10:00:38
Barbaraa
Hallo Micha,
zu Deiner Zusatzfrage an hary am am 30.06.2018 16:48:14:
Wenn Du mich fragen würdest, wie ich mein Makro dahingehend anpassen kann, könnte ich Dir folgenden Vorschlag machen:
Sub DatenKopieren0701()
Dim aTabelle()      As Variant
Dim aListe()        As Variant
'Ausgangsblatt
Dim lZeile          As Long         'Laufende Zeile
Dim lSpalte         As Long         'Laufende Spalte
'Ergebnisblatt
Dim lZielZeile      As Long         'Eintragszeile
aTabelle = Sheets("Quelle").Range("A1").CurrentRegion.Value
With Sheets("Ziel")
If .Cells(1, 1)  "Akte" Then
ReDim aListe(1 To 3, 1 To 1)
aListe(1, 1) = "Akte"
aListe(2, 1) = "Betrag"
aListe(3, 1) = "Bemerkung"
Else
aListe = Application.Transpose(.Range("A1").CurrentRegion.Value)
End If
For lZeile = 2 To UBound(aTabelle, 1)
For lSpalte = 4 To 7
For lZielZeile = 1 To UBound(aListe, 2)
If aListe(1, lZielZeile) = aTabelle(lZeile, 1) Then
If aListe(3, lZielZeile) = aTabelle(1, lSpalte) Then
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
Exit For
End If
End If
Next lZielZeile
If lZielZeile > UBound(aListe, 2) Then
If aTabelle(lZeile, lSpalte)  "" Then
ReDim Preserve aListe(1 To 3, 1 To lZielZeile)
aListe(1, lZielZeile) = aTabelle(lZeile, 1)
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
End If
End If
Next lSpalte
Next lZeile
aListe = Application.Transpose(aListe)
Range(.Cells(1, 1), _
.Cells(1 + UBound(aListe, 1) - LBound(aListe, 1), _
1 + UBound(aListe, 2) - LBound(aListe, 2))).Value _
= aListe
End With
End Sub
Wenn im Zielblatt A1 nicht "Akte" steht, wird die Tabelle neu angelegt.
Wenn doch, wird die bestehende Tabelle so geändert:
Bestehende Euroeinträge werden aktualisiert und neue Einträge werden unten angehängt.
Wenn im Quelleblatt ein Eurobetrag gelöscht wird, wird er auch im Zielblatt gelöscht, aber nicht anderen Werte dieser Zeile. Die Zeile bleibt, und alle folgenden Zeilen behalten wunschgemäß ihre Position.
Anzeige
AW: VBA - Werte kopieren
01.07.2018 19:13:12
Micha
Hi Barbara,
danke für deine Hilfestellung, leider bleibt das Makro bei mir an der Stelle
ReDim Preserve aListe(1 To 3, 0 To lZielZeile)
stehen.
Habe keine Ahnung woran das liegt.
https://www.herber.de/bbs/user/122420.xlsm
hast Du meinen Vorschlag nicht gesehen?
01.07.2018 19:24:00
robert
Gruß
AW: hast Du meinen Vorschlag nicht gesehen?
01.07.2018 20:47:41
Micha
Hallo Robert,
danke für deinen Vorschlag mit dem Einsatz von Power Query. Leider verschieben sich dabei die Zeilen in der Zieltabelle im Tabellenblatt "Ziel" weiter nach unten, wenn ich beispielsweise im Tabellenblatt "Quelle" einen neuen Eintrag in die Zeile "F2" eingebe.
https://www.herber.de/bbs/user/122423.xlsm
Neue Einträge sollen aber immer an das Ende der Zieltabelle gesetzt werden und nicht zwischen die bereits erzeugten Zielzeilen eingefügt werden.
Oder gibt es beim Einsatz von Power Query einen Trick, wie ich das umgehen kann und neue Einträge immer ans Ende der Zieltabelle eingefügt werden.
VG
Micha
Anzeige
Ja aber gehören Akten-Nr.nicht zusammen?
02.07.2018 08:05:49
robert
Hi,
ich denke eine Akte ist eine Akte und die Daaten gehören zusammen ausgewiesen-
oder was besagt die Akten-Nr. ?
Gruß
robert
AW: Ja aber gehören Akten-Nr.nicht zusammen?
02.07.2018 13:26:16
Micha
Hallo Robert,
da es sich hier um ein dynamisches System handelt, bei dem im Tabellenblatt "Ziel" mit den Basisdaten aus dem Tabellenblatt "Quelle" weitergearbeitet wird und nach dem Basisdaten im Tabellenblatt "Ziel" weitere Daten manuell bzw. über weitere Formeln hinzugetragen werden, dürfen sich die Zeileneinträge der Basisdaten nicht nach unten verschieben, da sonst die zugehörigen weiteren Einträge im Tabellenblatt "Ziel" nicht mehr zu den Basisdaten aus dem Tabellenblatt "Quelle" passen, weil die manuell eingetragenen Daten ihre Position im Tabellenblatt "Ziel" behalten.
Im Tabellenblatt "Ziel" werden beispielsweise noch Anordnungsdaten und sonstige Zusatzinformationen von einer anderen Abteilung hinzugetragen. Diese benötigt dafür jedoch bestimmte Basisdaten aus dem Tabellenblatt "Quelle", da nicht alle Daten doppelt und dreifach von diversen Bereichen manuell erfasst werden sollen.
Nachdem dann alle Daten und Berechnungen im Tabellenblatt "Ziel" erfolgt sind, lässt sich die weitere Auswertung mit einem Power Query realisieren. Mir geht es aber erst einmal darum, dass ich die Basisdaten aus dem Tabellenblatt "Quelle" in mein Tabellenblatt "Ziel" bekommen, damit dort mit den Daten weitergearbeitet werden kann.
Anzeige
verstehe kein Wort, aber- soll so sein :-) owT
02.07.2018 14:49:28
robert
AW: VBA - Werte kopieren
01.07.2018 19:40:44
Barbaraa
Hi Micha,
Hast Du Dich da etwa beim Abschreiben vertippt?
Kopiere doch einfach mein (und jetzt Dein) Makro in ein Modul.
Diese Problemzeile konnte ich weder
in deiner eben hochgeladenen Beispieldatei noch
in meinem zuvor gezeigtem Makro "Sub DatenKopieren0701()"
finden.
LGB
AW: VBA - Werte kopieren
01.07.2018 21:00:44
Micha
Babara,
danke für deine Rückinfo. Ich habe deinen Code kopiert und in meine Datei eingefügt. Der Code funkrioniert soweit auch erst einmal, aber sobald ich beispielsweise in die Zelle "E3" im Tabellenblatt "Quelle" einen neuen Wert eingebe, meldet das Makro einen Fehler in besagter Zeile... Die Zeile befindet sich ziemlich weit unten in der letzten If-Schleife.
Ich habe den Code jetzt hier einmal nochmal eingefügt und die besagte Zeile Fett und Kursiv hervorgehoben.
Sub DatenKopieren0701()
Dim aTabelle()      As Variant
Dim aListe()        As Variant
'Ausgangsblatt
Dim lZeile          As Long         'Laufende Zeile
Dim lSpalte         As Long         'Laufende Spalte
'Ergebnisblatt
Dim lZielZeile      As Long         'Eintragszeile
aTabelle = Sheets("Quelle").Range("A1").CurrentRegion.Value
With Sheets("Ziel")
If .Cells(1, 1)  "Akte" Then
ReDim aListe(1 To 3, 1 To 1)
aListe(1, 1) = "Akte"
aListe(2, 1) = "Betrag"
aListe(3, 1) = "Bemerkung"
Else
aListe = Application.Transpose(.Range("A1").CurrentRegion.Value)
End If
For lZeile = 2 To UBound(aTabelle, 1)
For lSpalte = 4 To 7
For lZielZeile = 1 To UBound(aListe, 2)
If aListe(1, lZielZeile) = aTabelle(lZeile, 1) Then
If aListe(3, lZielZeile) = aTabelle(1, lSpalte) Then
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
Exit For
End If
End If
Next lZielZeile
If lZielZeile > UBound(aListe, 2) Then
If aTabelle(lZeile, lSpalte)  "" Then
  ReDim Preserve aListe(1 To 3, 1 To lZielZeile)
aListe(1, lZielZeile) = aTabelle(lZeile, 1)
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
End If
End If
Next lSpalte
Next lZeile
aListe = Application.Transpose(aListe)
Range(.Cells(1, 1), _
.Cells(1 + UBound(aListe, 1) - LBound(aListe, 1), _
1 + UBound(aListe, 2) - LBound(aListe, 2))).Value _
= aListe
End With
End Sub
Vielleicht hast du ja noch einen Vorschlag, wie ich das beheben kann.
LG
Micha
Anzeige
AW: VBA - Werte kopieren
01.07.2018 21:39:39
Barbaraa
Hallo Micha
Probier mal:
Sub DatenKopieren0701a()
Dim aTabelle()      As Variant
Dim aListe()        As Variant
'Ausgangsblatt
Dim lZeile          As Long         'Laufende Zeile
Dim lSpalte         As Long         'Laufende Spalte
'Ergebnisblatt
Dim lZielZeile      As Long         'Eintragszeile
aTabelle = Sheets("Quelle").Range("A1").CurrentRegion.Value
With Sheets("Ziel")
If .Cells(1, 1)  "Akte" Then
ReDim aListe(1 To 3, 1 To 1)
aListe(1, 1) = "Akte"
aListe(2, 1) = "Betrag"
aListe(3, 1) = "Bemerkung"
Else
aListe = Application.Transpose(.Range("A1").CurrentRegion.Resize(, 3).Value)
End If
For lZeile = 2 To UBound(aTabelle, 1)
For lSpalte = 4 To 7
For lZielZeile = 1 To UBound(aListe, 2)
If aListe(1, lZielZeile) = aTabelle(lZeile, 1) Then
If aListe(3, lZielZeile) = aTabelle(1, lSpalte) Then
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
Exit For
End If
End If
Next lZielZeile
If lZielZeile > UBound(aListe, 2) Then
If aTabelle(lZeile, lSpalte)  "" Then
ReDim Preserve aListe(1 To 3, 1 To lZielZeile)
aListe(1, lZielZeile) = aTabelle(lZeile, 1)
aListe(2, lZielZeile) = aTabelle(lZeile, lSpalte)
aListe(3, lZielZeile) = aTabelle(1, lSpalte)
End If
End If
Next lSpalte
Next lZeile
aListe = Application.Transpose(aListe)
.Range(.Cells(1, 1), _
.Cells(1 + UBound(aListe, 1) - LBound(aListe, 1), _
1 + UBound(aListe, 2) - LBound(aListe, 2))).Value _
= aListe
End With
End Sub
Der Fehler kommt daher, weil die angrenzenden Zellen der Zieltabelle nicht leer waren. Diese Möglichkeit wurde nicht berücksichtigt.
Da Du in der Zielzelle die Spalte D beschrieben hast, wurde diese in den Bereich "CurrentRegion" mit einbezogen. In der Zeile, in der der Fehler aufgetreten ist, wurde allerdings von drei Spalten ausgegangen.
Das ist nun repariert. Nun werden nur die ersten drei Spalten betrachtet und Deine Kommentare in Spalte D stören nicht weiter.
Noch ein Hinweis:
Wenn Du dieses Makro "Sub DatenKopieren0701a()" in das Tabellenmodul Tabelle1(Quelle) kopierst und so in der ersten Makrozeile umbenennst:
"Private Sub Worksheet_Change(ByVal Target As Range)"
dann wird die Aktualisierung der Zieltabelle bei jedem händischen Eintrag im Quelle-Blatt automatisch aktualisiert und Du ersparst Dir das händische Aufrufen des Makros.
Wenn Du das nicht willst, lösche dieses Makro im Modul Tabelle1(Quelle) wieder oder kommentiere es aus.
LGB
Anzeige
AW: VBA - Werte kopieren
01.07.2018 21:58:29
Micha
Hallo Barbara,
ich danke dir!!! Das klappt jetzt wunderbar. Ich bin begeistert.
Danke auch für den Tipp mit dem "Privat Sub"-Eintrag in das Tabellenblatt "Quelle". :-)))
Vielen lieben Dank und dir noch einen schönen Abend.
LG
Micha
AW: VBA - Werte kopieren
02.07.2018 12:48:51
Micha
Hallo Barbara,
ich hoffe, du kannst mir nochmal helfen.
Nachdem ich den VBA-Code aus meiner Beispieltabelle versucht habe, in meiner Originaltabelle umzusetzen, habe ich wieder ein Problem...
1.) Die relevanten Werte aus der jeweils letzten Zeile im Tabellenblatt "Quelle" werden jetzt leider nicht mehr in mehr in das Tabellenblatt "Ziel" kopiert.
2.) Zudem habe ich jetzt wieder das Problem, dass wenn ich in den bestehenden Zeileneinträgen im Tabellenblatt "Quelle" einen Wert hinzufüge, dass sich dadurch wieder die Zeilen im Tabellenblatt "Ziel" nach unten verschiebe und nicht ganz unten in der ersten leeren Zeile im Tabellenblatt "Ziel" angehängt werden (z.B. wenn ich im Tabellenblatt "Quelle" in die Zelle "S2" einen neuen Eintrag vornehmen).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Quell_Tabellenblatt()      As Variant
Dim Ziel_Tabellenblatt()        As Variant
'Ausgangsblatt
Dim lfd_Zeile_Quelle          As Long         'Laufende Zeile
Dim lfd_Spalte_Quelle         As Long         'Laufende Spalte
'Ergebnisblatt
Dim lfd_Zeile_Ziel      As Long         'Eintragszeile
Quell_Tabellenblatt = Sheets("Quelle").Range("A1").CurrentRegion.Value
With Sheets("Ziel")
If .Cells(1, 4)  "Aktenzeichen" Then
ReDim Ziel_Tabellenblatt(1 To 17, 4 To 4)
Ziel_Tabellenblatt(1, 4) = "Akten-zeichen"
Ziel_Tabellenblatt(2, 4) = "AO-Grund"
Ziel_Tabellenblatt(3, 4) = "Vertrags-art"
Ziel_Tabellenblatt(4, 4) = "Investitionsnr./ Sachkonto lt. VOA"
Ziel_Tabellenblatt(6, 4) = "Sach-bearbeiter"
Ziel_Tabellenblatt(7, 4) = "KV UR-Nr."
Ziel_Tabellenblatt(8, 4) = "MA UR-Nr."
Ziel_Tabellenblatt(9, 4) = "Notar"
Ziel_Tabellenblatt(10, 4) = "Vertragspartner"
Ziel_Tabellenblatt(11, 4) = "Kaufpreis gesamt"
Ziel_Tabellenblatt(12, 4) = "Fläche gesamt"
Ziel_Tabellenblatt(13, 4) = "Betrag lt. Vertrag"
Ziel_Tabellenblatt(14, 4) = "freigemeldete HH-Mittel"
Ziel_Tabellenblatt(15, 4) = "Finanzierung"
Ziel_Tabellenblatt(16, 4) = "Anlagennr."
Else
Ziel_Tabellenblatt = Application.Transpose(.Range("A1").CurrentRegion.Resize(, 21). _
Value)
End If
For lfd_Zeile_Quelle = 2 To UBound(Quell_Tabellenblatt, 1)
For lfd_Spalte_Quelle = 14 To 21
For lfd_Zeile_Ziel = 4 To UBound(Ziel_Tabellenblatt, 2)
If Ziel_Tabellenblatt(1, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 1) Then
If Ziel_Tabellenblatt(3, lfd_Zeile_Ziel) = Quell_Tabellenblatt(1,  _
lfd_Spalte_Quelle) Then
Ziel_Tabellenblatt(2, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, lfd_Spalte_Quelle)
Ziel_Tabellenblatt(3, lfd_Zeile_Ziel) = Quell_Tabellenblatt(1,  _
lfd_Spalte_Quelle)
Exit For
End If
End If
Next lfd_Zeile_Ziel
If lfd_Zeile_Ziel > UBound(Ziel_Tabellenblatt, 2) Then
If Quell_Tabellenblatt(lfd_Zeile_Quelle, lfd_Spalte_Quelle)  "" Then
ReDim Preserve Ziel_Tabellenblatt(1 To 17, 4 To lfd_Zeile_Ziel)
'Füllt die 1. Spalte ("Aktenzeichen") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(1, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 1)
'Füllt die 3. Spalte ("Vertragsart") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(3, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 2)
'Füllt die 6. Spalte ("Sachbearbeiter") der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(6, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 4)
'Füllt die 7. Spalte ("KV UR-Nr.") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(7, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 8)
'Füllt die 8. Spalte ("MA UR-Nr.") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(8, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 9)
'Füllt die 9. Spalte ("Notar") in der Zieltabelle mit den zugehörigen  _
Daten aus der Quelltabelle
Ziel_Tabellenblatt(9, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 6)
'Füllt die 10. Spalte ("Vertragspartner") in der Zieltabelle mit den  _
zugehörigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(10, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 7)
'Füllt die 11. Spalte ("Kaufpreis gesamt") in der Zieltabelle mit den  _
zugehörigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(11, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 10)
'Füllt die 12. Spalte ("Fläche gesamt") in der Zieltabelle mit den  _
zugehörigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(12, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 11)
'Füllt die 14. Spalte ("freigemeldete HH-Mittel") in der Zieltabelle  _
mit den zugehörigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(14, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 22)
'Füllt die 15. Spalte ("Finanzierung") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(15, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 12)
'Füllt die 16. Spalte ("Anlagennr.") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(16, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, 13)
Ziel_Tabellenblatt(13, lfd_Zeile_Ziel) = Quell_Tabellenblatt( _
lfd_Zeile_Quelle, lfd_Spalte_Quelle)
'Füllt die 2. Spalte ("AO-Grund") in der Zieltabelle mit den zugehö _
rigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(2, lfd_Zeile_Ziel) = Quell_Tabellenblatt(1,  _
lfd_Spalte_Quelle)
'Füllt die 4. Spalte ("Investitionsnr./Sachkonto") in der Zieltabelle  _
mit den zugehörigen Daten aus der Quelltabelle
Ziel_Tabellenblatt(4, lfd_Zeile_Ziel) = Ziel_Tabellenblatt(15,  _
lfd_Zeile_Ziel)
End If
End If
Next lfd_Spalte_Quelle
Next lfd_Zeile_Quelle
Ziel_Tabellenblatt = Application.Transpose(Ziel_Tabellenblatt)
.Range(.Cells(4, 1), _
.Cells(1 + UBound(Ziel_Tabellenblatt, 1) - LBound(Ziel_Tabellenblatt, 1), _
1 + UBound(Ziel_Tabellenblatt, 2) - LBound(Ziel_Tabellenblatt, 2))).Value _
= Ziel_Tabellenblatt
End With
End Sub
Was habe ich falsch gemacht?
Eine Kurzfassung meiner Originaldatei habe ich dir wieder als Anlage beigefügt.
https://www.herber.de/bbs/user/122439.xlsm
Für deine erneute Hilfe wäre ich dir sehr dankbar.
LG
Micha
Immewr wieder das gleiche.....
02.07.2018 14:54:04
robert
...die Beispieldatei weicht vom Original TOTAL! ab.
Da macht helfen Spass :-((
AW: Immewr wieder das gleiche.....
02.07.2018 19:12:34
Barbaraa
Die Lösung zu deinem Problem interessiert hier ausser Dich niemanden.
Kann ich Dir gerne per Mail (oder skype oder whatsapp) beantworten.
Eines kann ich Dir jetzt schon sagen:
Ein neues "Aktenzeichen" legt im Ziel noch keine neue Zeile an.
Eine neue Zeile wird erst angelegt, wenn zB ein "KP", "Notar KV" oder ähnliches eingetragen ist.
Und da sind noch ein paar andere Fehler.
LGB
Kontaktdaten
02.07.2018 20:57:53
Micha
Hallo Barbara,
das ist lieb, dass du mir bei meinem Problem behilflich bist. Du kannst mir gern per E-Mail an micha.paetsch@gmail.com schreiben.
Ich bin dir für deine Hilfe sehr dankbar.
Vielen lieben Dank und LG
Micha

317 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige