Schnittmenge aus 2 Sheets erstellen

Hallo Beisammen.
Ich habe innerhalb einer Datei insgesamt 2 Sheets mit unterschiedlichen Tabellen.
Zeile 1 ist jeweils die Überschrift, die Werte beginnen jeweils ab A5 (ohne leere Zeile) und endet mal bei A300, mal bei A4000. Die Werte innerhalb der Sheets sollten von Dubletten bereinigt werden, dh die gesamte Zeile kann gelöscht werden.
Sollte jedoch Sheet-Übergreifend eine Übereinstimmung vorliegen bei den Werten in Spalte A (zu Sheet2 A5:A4000), dann wäre es klasse, wenn ein neuer Sheet entsteht und diese "Treffer" mit allen nicht-leeren Einträgen aus Sheet 1 und Sheet 2 untereinander kopiert.
Eine Lösung hierfür habe ich stümperhaft hinbekommen, jedoch mit dem Macrorecorder und händisch erfassten Formeln, daher ist meine Tabelle verschoben auf Spalte B um eine Hilfsspalte mit den Formeln nutzen zu können..

Sub Treffer()
' ergebnis überprüfen Makro
Range("A4").Value = "Sheet2"
Columns("A:A").EntireColumn.AutoFit
Rows("4:4").RowHeight = 35 'Überschrift
Range("B1").FormulaR1C1 = "=SUBTOTAL(3,R[4]C:R[1048575]C)"
Range("B1").Select
With Selection
.HorizontalAlignment = xlRight
End With
Range("A5").FormulaR1C1 = _
"=IF(MATCH(RC[1],Sheet1!C[1],0)=ROW(),"""",""Sheet2"")"
Range("A5").AutoFill Destination:=Range("A5:A3500"), Type:=xlFillDefault
Range("A4:Z4").Select
Selection.AutoFilter
ActiveSheet.Range("$A$4:$F$3500").AutoFilter Field:=1, Criteria1:= _
"Sheet2"
Range("B4:Z3500").Copy 'übernimmt direkt auch die Überschrift
Sheets("Treffer").Select
ActiveSheet.Paste
Sheets("Dora").Select
ActiveSheet.Range("$A$4:$Z$3500").AutoFilter Field:=1
Columns("A:A").EntireColumn.Hidden = True
Sheets("Treffer").Select
Rows("5:5").Select
ActiveWindow.FreezePanes = True
Range("A1").Select
ActiveCell.FormulaR1C1 = "Anzahl" 'gibt die Anzahl der Treffer an
With Selection
.HorizontalAlignment = xlRight
End With
Sheets("Treffer").Select
Range("B1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[4]C[-1]:R[1048575]C[-1])"
With Selection
.HorizontalAlignment = xlLeft
End With
Rows("4:4").RowHeight = 35
Range("A2").Select
End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Sub Treffer() Set sh1 = Sheets(1) Set sh2 = Sheets(2) Set sh3 = Sheets(3) For i = 5 To sh1.Cells(Rows.Count, 1).End(xlUp).Row nz = sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' neue Zeile If WorksheetFunction.CountIf(sh3.Columns(1), sh1.Cells(i, 1)) = 0 Then sh1.Rows(i).Copy sh3.Cells(nz, 1) End If Next i For i = 5 To sh2.Cells(Rows.Count, 1).End(xlUp).Row nz = sh3.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' neue Zeile If WorksheetFunction.CountIf(sh3.Columns(1), sh2.Cells(i, 1)) = 0 Then sh2.Rows(i).Copy sh3.Cells(nz, 1) End If Next i End Sub

Beliebteste Forumthreads (12 Monate)

Schnittmenge aus 2 Sheets erstellen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread