Supportnet / Forum / Tabellenkalkulation
VBA Datensatz mit Nr suchen zu Ziel kopieren
Frage
Folgendes Problem:
Ich habe zwei Datenblätter in einer Datei, die jeweils Angaben zu Proben enthalten. Jedem Datensatz in dem jeweiligen Tabellenblatt ist eine Proben-Nr. zugeordnet, die in Tabelle 1 in Spalte A, in Tabelle 2 in Spalte H steht.
Ich möchte jetzt in Tabelle 2 suchen, ob zur Probe x aus Tabelle 1 auch Angaben in Tabelle 2 enthalten sind. Sind Angaben vorhanden, sollen diese Angaben aus Tabelle 2 in Tabelle 1 in die gleiche Zeile ab Spalte I kopiert werden, so dass ich alle Angaben zur Probe in einem Tabellenblatt habe.
Wie kann ich das mit VBA lösen?
Ich finde zwar die Probe, kann abe nicht ausdrücken, dass die Angaben in Tabelle 1 zur entsprechenden Probe kopiert werden.
Wer kann mir da helfen?
Antwort 1 von JoeKe
Hallo BRemma,
versuch es mal so:
Option Explicit
Sub proben()
Application.ScreenUpdating = False
Dim suchZelle As Range, findZelle As Range, _
suchZeile As Long, findZeile As Long, i As Long, k As Long
i = Sheets("Tabelle2").Cells(Rows.Count, 8).End(xlUp).Row
k = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
For Each suchZelle In Sheets("Tabelle2").Range("H1:H" & i)
For Each findZelle In Sheets("Tabelle1").Range("A1:A" & k)
If suchZelle = findZelle Then
suchZeile = suchZelle.Row
findZeile = findZelle.Row
Sheets("Tabelle2").Range(Cells(suchZeile, 9), Cells(suchZeile, Columns.Count).End(xlToLeft)).Copy
Sheets("Tabelle1").Cells(findZeile, 9).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
MfG
JöKe
versuch es mal so:
Option Explicit
Sub proben()
Application.ScreenUpdating = False
Dim suchZelle As Range, findZelle As Range, _
suchZeile As Long, findZeile As Long, i As Long, k As Long
i = Sheets("Tabelle2").Cells(Rows.Count, 8).End(xlUp).Row
k = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
For Each suchZelle In Sheets("Tabelle2").Range("H1:H" & i)
For Each findZelle In Sheets("Tabelle1").Range("A1:A" & k)
If suchZelle = findZelle Then
suchZeile = suchZelle.Row
findZeile = findZelle.Row
Sheets("Tabelle2").Range(Cells(suchZeile, 9), Cells(suchZeile, Columns.Count).End(xlToLeft)).Copy
Sheets("Tabelle1").Cells(findZeile, 9).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
MfG
JöKe
Antwort 2 von BRemma
Vielen Dank für den Code, er hat mir sehr geholfen. Allerdings habe ich noch festgestellt, dass dieser Code nur funktioniert, wenn ich das Blatt "Stammdaten" aktiv habe. Wenn ich das Blatt "99-05_d" aktiv habe bleibt das Makro immer in der Zeile - Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy -
stehen und zeigt einen Fehler an. Warum weiß ich nicht. vielleicht kannst Du mir das erklären.
Vielen Dank schon jetzt.
MFG
BRemma
stehen und zeigt einen Fehler an. Warum weiß ich nicht. vielleicht kannst Du mir das erklären.
Vielen Dank schon jetzt.
MFG
BRemma
Sub vergleichen()
Dim suchZelle As Range, findZelle As Range
Dim suchZeile As Long, findZeile As Long
Dim letzteZeileVon As Long, letzteZeileZu As Long
´Überschriften der einen Tabelle in die andere Tabelle kopieren
Sheets("Stammdaten").[A1:E1].Copy Destination:=Sheets("99-05_d").[H1]
Application.ScreenUpdating = True
letzteZeileVon = Sheets("99-05_d").Range("G65536").End(xlUp).Row
letzteZeileZu = Sheets("Stammdaten").Range("A65536").End(xlUp).Row
For Each suchZelle In Sheets("Stammdaten").Range("A2:A" & letzteZeileZu)
For Each findZelle In Sheets("99-05_d").Range("G2:G" & letzteZeileVon)
If suchZelle = findZelle Then
suchZeile = suchZelle.Row
findZeile = findZelle.Row
Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy
Sheets("99-05_d").Cells(findZeile, 8).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Antwort 3 von JoeKe
Hallo BRemma,
das liegt daran, dass sich Excel mit dem kopieren nicht aktiver Bereiche schwer tut.
Wenn du die Zeilen:
so:
Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy _
Destination:=Sheets("99-05_d").Cells(findZeile, 8)
abänderst, sollte es keine Probleme mehr geben.
MfG
JöKe
das liegt daran, dass sich Excel mit dem kopieren nicht aktiver Bereiche schwer tut.
Wenn du die Zeilen:
Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy
Sheets("99-05_d").Cells(findZeile, 8).PasteSpecial
so:
Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy _
Destination:=Sheets("99-05_d").Cells(findZeile, 8)
abänderst, sollte es keine Probleme mehr geben.
MfG
JöKe
Antwort 4 von nighty
hi jöke :)
alternative zu pastespezial :))
angenommen Sheets(2).Range("A1:A2") ist jeweils eine formel enthalten,so werden nur die werte in
Sheets(1).Range("A1").Value2 dargestellt (ab A1)
gruss nighty
Option Explicit
Sub test()
Sheets(2).Range("A1:A2") = Sheets(1).Range("A1").Value2
End Sub
alternative zu pastespezial :))
angenommen Sheets(2).Range("A1:A2") ist jeweils eine formel enthalten,so werden nur die werte in
Sheets(1).Range("A1").Value2 dargestellt (ab A1)
gruss nighty
Option Explicit
Sub test()
Sheets(2).Range("A1:A2") = Sheets(1).Range("A1").Value2
End Sub
Antwort 5 von nighty
hi jöke :))
die bereichsangaben muessen identisch sein bemerkte ich noch :))
gruss nighty
die bereichsangaben muessen identisch sein bemerkte ich noch :))
gruss nighty
Antwort 6 von BRemma
Hallo Jöke,
ich habe es mit der Zeile
probiert, das funktioniert aber nicht. Das Makro bleibt immer wieder an der Stelle stehen und kopiert nicht. Es hilft immer noch nur das 2. Blatt aufschlagen und dann Makro ausführen.
ich habe es mit der Zeile
Sheets("Stammdaten").Range(Cells(suchZeile, 1), Cells(suchZeile, 5)).Copy _
Destination:=Sheets("99-05_d").Cells(findZeile, 8)
probiert, das funktioniert aber nicht. Das Makro bleibt immer wieder an der Stelle stehen und kopiert nicht. Es hilft immer noch nur das 2. Blatt aufschlagen und dann Makro ausführen.