Supportnet Computer
Planet of Tech

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

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

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:

  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

Antwort 5 von nighty

hi jöke :))

die bereichsangaben muessen identisch sein bemerkte ich noch :))

gruss nighty

Antwort 6 von BRemma

Hallo Jöke,
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.

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: