Supportnet / Forum / Tabellenkalkulation

Hallo, man stelle sich folgendes Problem vor: Eine Tabelle enthält mehrere Arbeitsblätter. Ich möchte nun die Werte in Spalte A in Tabellenblatt A mit den Werten in Spalte A in Tabellenblatt B vergleichen. Wenn die Werte identisch sind, sollen bestimmte Zellen der gleichen Zeile in ein neues Tabellenblatt kopiert werden. Z.B. wenn A1(in Tabellenblatt A) = A1 (in Tabellenblatt B), dann kopiere A1 (Tab.A), B1(Tab.B), H1(Tab.A), etc. in Tabellenblatt X. Ich habe schon ein Makro gefunden ([url=https://supportnet.de/fresh/2005/6/id1084426.asp]siehe hier[/url]), dass die erste Spalte verschiedener Tabellenblätter miteinander vergleicht und doppelte in ein neues Tabellenblatt kopiert, allerdings bräuchte ich noch die Kopierfunktion für einige Zellen(4-5) mehr. Wäre echt super wenn mir jemand helfen könnte. Vielen Dank ! Mc_DoC

hi Mc_DoC :-)

bitte frage corus der das makro erstellt hat oder stelle deine frage neu mit besserer beschreibung

bedenke das keiner gerne makros umschreibt,neu schreiben ist meist effektiver

gruss nighty

hi Mc_DoC :-)

hier ein beispiel

gruss nighty

Option Explicit
Sub vergleich()
Call EventsOff
Dim zaehler0 As Long, zaehler1 As Long, spaltea1 As Long
If Sheets(1).Range("A" & Rows.Count).End(xlUp).Row > Sheets(2).Range("A" & Rows.Count).End(xlUp).Row Then
spaltea1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Else
spaltea1 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
End If
ReDim sh1(spaltea1, 1) As Variant
ReDim sh2(spaltea1, 1) As Variant
Sheets(2).Select
sh2() = Range(Cells(1, 1), Cells(spaltea1, 1))
Sheets(1).Select
sh1() = Range(Cells(1, 1), Cells(spaltea1, 1))
For zaehler0 = 1 To spaltea1
For zaehler1 = 1 To spaltea1
If sh1(zaehler0, 1) = sh2(zaehler1, 1) Then
Rem hier ein beispiel einer zeile die kopiert wird
Rows(zaehler0 & ":" & zaehler0).Copy Sheets(2).Range("A" & zaehler1)
End If
Next zaehler1
Next zaehler0
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

hi all :-)

fuer interessierte :-)

in diesem beispiel sind die beiden selectionen zwingend,eine der seltenden ausnahmen,hier bei der zuweisung des array

gruss nighty

Hallo nighty,

vielen Dank für deine Hilfe. Habe das Makro noch nicht ausprobiert, bin noch am Anpassen und da ich keine Ahnung von VB habe, kann das noch etwas dauern.
Wie kann ich denn jetzt mehrere Zellen kopieren? Muss ich diese Zeile einfach kopieren und anpassen?
"Rows(zaehler0 & ":" & zaehler0).Copy Sheets(2).Range("A" & zaehler1)"
Wohin wird hier jetzt eigentlich kopiert? Würde nämlich gerne das Tabellenblatt angeben...
Ok, ich hoffe ich falle nicht zu sehr auf die Nerven, bin halt absoluter Neuling was solche Sachen angeht...
Also nochmal danke.
Gruß, Mc_DoC

Hallo nochmal!

Ok, ich versuche mich nochmal genauer auszudrücken.

Ich möchte nur die erste Spalte von Tabellenblatt "A" mit Tabellenblatt "B" vergleichen. Wenn es hier eine Übereinstimmung gibt, möchte ich mehrere Zellen der betreffenden Zeile in ein neues Tabellenblatt kopieren, und zwar Zellen aus Tabellenblatt "A" und aber auch aus Tabellenblatt "B".

Z.B. Zelle A8 von Tabellenblatt "A" entspricht Zelle A15 von Tabellenblatt "B". Jetzt sollen die Zellen C8, H8 und K8 aus Tabellenblatt "A" , die Zellen B15, G15 und L15 aus Tabellenblatt "B" sowie der übereinstimmende Wert aus Spalte A in ein neues Tabellenblatt (sagen wir "X") in eine Zeile hintereinander kopiert werden.
Und dieser Vorgang soll eben so lange wiederholt werden bis alle Übereinstimmungen im neuen Tabellenblatt versammelt sind.

Hoffentlich war es jetzt verständlicher, würde mir nämlich viel Arbeit sparen (es geht um ca. 13000 Zeilen die verglichen werden sollen).

Ok, also nochmals danke!

Viele Grüße,
Mc_DoC

hi Mc_DoC

ein versuch :-)

gruss nighty

ueberschrifte vorrausgesetzt in allen drei tabellen
tabelle1 spalte a wird mit tabelle2 spalte a verglichen
bei fund angegebene zellen von tabelle1 wie tabelle2
nach tabelle3 kopiert

Option Explicit
Sub vergleich()
Call EventsOff
Dim zaehler0 As Long, zaehler1 As Long, spaltea1 As Long, zeile As Long
If Sheets(1).Range("A" & Rows.Count).End(xlUp).Row > Sheets(2).Range("A" & Rows.Count).End(xlUp).Row Then
spaltea1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Else
spaltea1 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
End If
ReDim sh1(spaltea1, 1) As Variant
ReDim sh2(spaltea1, 1) As Variant
Sheets(2).Select
sh2() = Range(Cells(1, 1), Cells(spaltea1, 1))
Sheets(1).Select
sh1() = Range(Cells(1, 1), Cells(spaltea1, 1))
For zaehler0 = 2 To spaltea1
For zaehler1 = 2 To spaltea1
If sh1(zaehler0, 1) = sh2(zaehler1, 1) Then
zeile = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(3).Range("A" & zeile & ":D" & zeile) = Array(Sheets(1).Range("A" & zaehler0), Sheets(1).Range("C" & zaehler0), Sheets(1).Range("H" & zaehler0), Sheets(1).Range("K" & zaehler0))
Sheets(3).Range("E" & zeile & ":G" & zeile) = Array(Sheets(2).Range("B" & zaehler1), Sheets(2).Range("G" & zaehler1), Sheets(2).Range("L" & zaehler1))
End If
Next zaehler1
Next zaehler0
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

• Zellen vergleichen
• Zellen vergleichen
• Statistik bezogen auf mehrere Zellen unterschiedlicher Tabellenblätter
• Zellen vergleichen und kopieren
• mehrere Tabellenblätter in andere Arbeitsmappe kopieren