2 Spalten nach Doppelungen prüfen u. übertragen

Computer: Software & Programmierung Visual Basic
#1

Liebe Excel-Spezialisten,

irgendwie bin ich gerade etwas „eingerostet“, da ich zzt. nicht mehr so viel in Excel unterwegs bin…

Mein Problem:
2 Excel-Dateien, nennen wir sie mal „Datei1“ und „Datei2“ sind mit div. Daten gefüllt (Spalten A - CC und Zeilen 10 - 150). Die Spaltentitel (Überschriften) befinden sich in der Zeile 9 und sind in beiden Dateien identisch.
In Datei1 und Datei2 muss nun die Spalte K auf Doppelungen geprüft werden.
Wenn Doppelungen auftreten, sollen die betroffenen Zeilen (A - CC) in einem anderen Excel-Blatt übertragen werden.

Für eure Unterstützung bedanke ich mich schon mal im Voraus! :smile:

Viele Grüsse,
Melanie

#2

In Datei1 und Datei2 muss nun die Spalte K auf Doppelungen
geprüft werden.
Wenn Doppelungen auftreten, sollen die betroffenen Zeilen (A -
CC) in einem anderen Excel-Blatt übertragen werden.

Hallo Melanie,

du schreibst zwar „datei“ aber benutzt auch die Wortwahl „anderes Blatt“ deshalb nachfrage, Datei1 und 2 sind Dateien also Excel-Mappen?
Wie heißen denn dann die Blätter?
Wie die datei wo das andere Blatt ist und wie heißt es?

Können auch doppelte werte in K innerhalb eines Blattes auftreten?

Gruß
Reinhard

#3

Hallo Reinhard,

habe gerade die Datei1 und Datei2 zu einer gemacht. Ist vermutlich einfacher.

Aktuell sieht es so aus,
dass es nur noch eine Datei gibt (Datei1) mit Tabelle1 und Tabelle2, hier muss die Spalte K auf Duplikate verglichen werden und Duplikate sollen in Tabelle3 übertragen werden. Hier muss es dann die ganze betroffene Zeile sein.

Viele Grüsse
Melanie

#4

dass es nur noch eine Datei gibt (Datei1) mit Tabelle1 und
Tabelle2, hier muss die Spalte K auf Duplikate verglichen
werden und Duplikate sollen in Tabelle3 übertragen werden.
Hier muss es dann die ganze betroffene Zeile sein.

Hallo Melanie,

rechts wird noch eine Spalte angelegt, dort steht der Blattname aus dem die Zeile stammt.
Wenn du das nicht brauchst mach ganz unten im Code das Hochkomma weg.

Gruß
Reinhard

In ein Standardmodul, Modul1 o.ä.

Option Explicit

Sub Doppelte()
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet, Formel As String
Dim Zei1 As Long, Zei2 As Long, Zei3 As Long, Spa3 As Long, strSpa3 As String
On Error GoTo hell
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Set wks3 = Worksheets("Tabelle3")
Zei1 = wks1.Cells(wks1.Rows.Count, 11).End(xlUp).Row
Zei2 = wks2.Cells(wks2.Rows.Count, 11).End(xlUp).Row
Application.ScreenUpdating = False
With wks3
 .UsedRange.ClearContents
 wks1.Range("A1:smiley:A" & Zei1).Copy Destination:=.Cells(3, 100)
 wks2.Range("A2:smiley:A" & Zei2).Copy Destination:=.Cells(Zei1 + 3, 100)
 wks1.Range("A1:smiley:A1").Copy Destination:=.Cells(1, 100)
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 Zei3 = .Cells(.Rows.Count, 110).End(xlUp).Row
 .Cells(1, Spa3 + 1).Value = "Blatt"
 .Cells(3, Spa3 + 1).Value = "Blatt"
 .Cells(1, Spa3 + 2).Value = "Zaehlen"
 .Cells(3, Spa3 + 2).Value = "Zaehlen"
 .Range(.Cells(4, Spa3 + 1), .Cells(Zei1 + 2, Spa3 + 1)) = wks1.Name
 .Range(.Cells(Zei1 + 3, Spa3 + 1), .Cells(Zei3, Spa3 + 1)) = wks2.Name
 strSpa3 = Split(.Cells(1, 110).Address, "$")(1)
 Formel = "=COUNTIF(" & strSpa3 & ":" & strSpa3 & "," & strSpa3 & "4)"
 .Range(.Cells(4, Spa3 + 2), .Cells(Zei3, Spa3 + 2)).Formula = Formel
 .Cells(2, Spa3 + 2).Value = "\>1"
 .Range(.Cells(3, 100), .Cells(Zei3, Spa3 + 2)).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=.Range(.Cells(1, 100), .Cells(2, Spa3 + 2)), \_
 CopyToRange:=.Cells(1, 1), Unique:=False
 .Columns("CV:IV").Clear
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 .Columns(Spa3).Clear
 '.Columns(Spa3 - 1).Clear
End With
hell:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox Err.Number & vbCr & Err.Description
End Sub
#5

Hallo Reinhard,

das ging ja fix :smile:

Habe es gerade mal ausprobiert und es funktioniert! Allerdings fehlt noch etwas…

Der Übertrag der Duplikate in die Tabelle3 sollten die kompletten Zeilen beeinhalten.
Die Tabelle1 und Tabelle2 sind von Spalte A bis Spalte CL mit Daten gefüllt
und die Prüfung der Doppelung gilt für Spalte K ab Zeile 10.

In der Zeile 9 befinden sich die Überschriften, welche natürlich mit übertragen werden sollen.

Und die Tabelle3 soll alle Daten gleich ab Spalte A übernehmen.

Grüsse
Melanie

#6

Der Übertrag der Duplikate in die Tabelle3 sollten die
kompletten Zeilen beeinhalten.
Die Tabelle1 und Tabelle2 sind von Spalte A bis Spalte CL mit
Daten gefüllt
und die Prüfung der Doppelung gilt für Spalte K ab Zeile 10.

In der Zeile 9 befinden sich die Überschriften, welche
natürlich mit übertragen werden sollen.

Und die Tabelle3 soll alle Daten gleich ab Spalte A
übernehmen.

Hallo Melanie,

nachfolgend der Code.
Anbei eine Beispielmappe die funktioniert:

http://www.file-upload.net/download-3390162/kwMelani…

Gruß
Reinhard

Option Explicit

Sub Doppelte()
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet, Formel As String
Dim Zei1 As Long, Zei2 As Long, Zei3 As Long, Spa3 As Long, strSpa3 As String
On Error GoTo hell
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Set wks3 = Worksheets("Tabelle3")
Zei1 = wks1.Cells(wks1.Rows.Count, 11).End(xlUp).Row
Zei2 = wks2.Cells(wks2.Rows.Count, 11).End(xlUp).Row
Application.ScreenUpdating = False
With wks3
 .UsedRange.ClearContents
 wks1.Range("A9:smiley:A" & Zei1).Copy Destination:=.Cells(3, 100)
 wks2.Range("A10:smiley:A" & Zei2).Copy Destination:=.Cells(Zei1 - 5, 100)
 wks1.Range("A9:smiley:A9").Copy Destination:=.Cells(1, 100)
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 Zei3 = .Cells(.Rows.Count, 110).End(xlUp).Row
 .Cells(1, Spa3 + 1).Value = "Blatt"
 .Cells(3, Spa3 + 1).Value = "Blatt"
 .Cells(1, Spa3 + 2).Value = "Zaehlen"
 .Cells(3, Spa3 + 2).Value = "Zaehlen"
 .Range(.Cells(4, Spa3 + 1), .Cells(Zei1 + 2, Spa3 + 1)) = wks1.Name
 .Range(.Cells(Zei1 + 3, Spa3 + 1), .Cells(Zei3, Spa3 + 1)) = wks2.Name
 strSpa3 = Split(.Cells(1, 110).Address, "$")(1)
 Formel = "=COUNTIF(" & strSpa3 & ":" & strSpa3 & "," & strSpa3 & "4)"
 .Range(.Cells(4, Spa3 + 2), .Cells(Zei3, Spa3 + 2)).Formula = Formel
 .Cells(2, Spa3 + 2).Value = "\>1"
 .Range(.Cells(3, 100), .Cells(Zei3, Spa3 + 2)).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=.Range(.Cells(1, 100), .Cells(2, Spa3 + 2)), \_
 CopyToRange:=.Cells(1, 1), Unique:=False
 .Columns("CV:IV").Clear
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 .Columns(Spa3).Clear
 '.Columns(Spa3 - 1).Clear
End With
hell:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox Err.Number & vbCr & Err.Description
End Sub
#7

Hallo Reinhard,

tausend Dank! Du bist echt klasse!

Grüsse
Melanie

#8

Hallo Reinhard,

es hat sich gerade wieder eine kleine Feinheit ergeben.
Gibt es die Möglichkeit, die Spalte K noch feiner zu filtern? In der besagten Spalte steht z.B. folgende Nummer X123 456789 1011 wobei sich die Suche nach den Doppelungen nur noch auf die 5. - 10. Stelle beziehen soll.

Grüsse
Melanie

#9

es hat sich gerade wieder eine kleine Feinheit ergeben.
Gibt es die Möglichkeit, die Spalte K noch feiner zu filtern?
In der besagten Spalte steht z.B. folgende Nummer X123
456789 1011 wobei sich die Suche nach den Doppelungen nur
noch auf die 5. - 10. Stelle beziehen soll.

Hallo Melanie,

Sub Doppelte()
Dim wks1 As Worksheet, wks2 As Worksheet, wks3 As Worksheet, Formel As String
Dim Zei1 As Long, Zei2 As Long, Zei3 As Long, Spa3 As Long, strSpa3 As String
On Error GoTo hell
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle2")
Set wks3 = Worksheets("Tabelle3")
Zei1 = wks1.Cells(wks1.Rows.Count, 11).End(xlUp).Row
Zei2 = wks2.Cells(wks2.Rows.Count, 11).End(xlUp).Row
Application.ScreenUpdating = False
With wks3
 .UsedRange.ClearContents
 wks1.Range("A9:smiley:A" & Zei1).Copy Destination:=.Cells(3, 100)
 wks2.Range("A10:smiley:A" & Zei2).Copy Destination:=.Cells(Zei1 - 5, 100)
 wks1.Range("A9:smiley:A9").Copy Destination:=.Cells(1, 100)
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 Zei3 = .Cells(.Rows.Count, 110).End(xlUp).Row
 .Cells(1, Spa3 + 1).Value = "Blatt"
 .Cells(3, Spa3 + 1).Value = "Blatt"
 .Cells(1, Spa3 + 2).Value = "K2"
 .Cells(3, Spa3 + 2).Value = "K2"
 .Cells(1, Spa3 + 3).Value = "Zaehlen"
 .Cells(3, Spa3 + 3).Value = "Zaehlen"
 .Range(.Cells(4, Spa3 + 1), .Cells(Zei1 - 6, Spa3 + 1)) = wks1.Name
 .Range(.Cells(Zei1 - 5, Spa3 + 1), .Cells(Zei3, Spa3 + 1)) = wks2.Name
 strSpa3 = Split(.Cells(1, 110).Address, "$")(1)
 .Range(.Cells(4, Spa3 + 2), .Cells(Zei3, Spa3 + 2)).Formula = "=MID(" & strSpa3 & "4,5,6)"
 strSpa3 = Split(.Cells(1, Spa3 + 2).Address, "$")(1)
 Formel = "=COUNTIF(" & strSpa3 & ":" & strSpa3 & "," & strSpa3 & "4)\*(" & strSpa3 & "4"""")"
 .Range(.Cells(4, Spa3 + 3), .Cells(Zei3, Spa3 + 3)).Formula = Formel
 .Cells(2, Spa3 + 3).Value = "\>1"
 .Range(.Cells(3, 100), .Cells(Zei3, Spa3 + 3)).AdvancedFilter Action:=xlFilterCopy, \_
 CriteriaRange:=.Range(.Cells(1, 100), .Cells(2, Spa3 + 3)), \_
 CopyToRange:=.Cells(1, 1), Unique:=False
 .Columns("CV:IV").Clear
 Spa3 = .Cells(1, Columns.Count).End(xlToLeft).Column
 .Columns(Spa3).Clear
 .Columns(Spa3 - 1).Clear
 '.Columns(Spa3 - 2).Clear
End With
hell:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox Err.Number & vbCr & Err.Description
End Sub

Gruß
Reinhard

#10

Super! Funktioniert einwandfrei! :smile: Danke schön.