AW: Auswertung dopelte Einträge
27.11.2007 18:51:00
Daniel
Hi
so gefällt mir das, erst mal selber ausprobieren, ob man es hinkriegt und dann erst fragen.
im Prinzip fehlen dir nur 2 Punkte:
du musst natürlich in jeder Schleife in BEIDEN Datenbereichen prüfen, wie oft der Wert vorkommt und das dann zusammenaddieren.
und du musst an der Stelle, wo die Zeilen-Nr der Fundstelle eingetragen wird, den Sheetnamen des Suchbereichs dazuschreiben.
das Makro sieht dann so aus:
Sub Doppelte_ermitteln_Neu3()
Dim shDaten As Worksheet
Dim shDaten2 As Worksheet
Dim shErg As Worksheet
Dim rngDaten As Range
Dim rngDaten2 As Range
Dim rngErg As Range
Dim Zelle As Range
Set shDaten = Sheets("Daten")
Set shDaten2 = Sheets("Daten (2)")
Set shErg = Sheets("Auswertung Doppelte")
shErg.UsedRange.Offset(1, 0).ClearContents
Set rngDaten = shDaten.Cells(1, 1).Resize(shDaten.Cells(65536, 1).End(xlUp).Row, 1)
Set rngDaten2 = shDaten2.Cells(1, 1).Resize(shDaten2.Cells(65536, 1).End(xlUp).Row, 1)
For Each Zelle In rngDaten
If WorksheetFunction.CountIf(rngDaten, Zelle.Value) + WorksheetFunction.CountIf( _
rngDaten2, Zelle.Value) > 1 Then
Set rngErg = shErg.Range("A:A").Find(what:=Zelle.Value, lookat:=xlWhole, LookIn:= _
xlValues)
If rngErg Is Nothing Then Set rngErg = shErg.Cells(65536, 1).End(xlUp).Offset(1, 0)
rngErg.Value = Zelle.Value
shErg.Cells(rngErg.Row, 255).End(xlToLeft).Offset(0, 1).Value = rngDaten.Parent.Name _
& " " & Zelle.Row
End If
Next
For Each Zelle In rngDaten2
If WorksheetFunction.CountIf(rngDaten, Zelle.Value) + WorksheetFunction.CountIf( _
rngDaten2, Zelle.Value) > 1 Then
Set rngErg = shErg.Range("A:A").Find(what:=Zelle.Value, lookat:=xlWhole, LookIn:= _
xlValues)
If rngErg Is Nothing Then Set rngErg = shErg.Cells(65536, 1).End(xlUp).Offset(1, 0)
rngErg.Value = Zelle.Value
shErg.Cells(rngErg.Row, 255).End(xlToLeft).Offset(0, 1).Value = rngDaten2.Parent. _
Name & " " & Zelle.Row
End If
Next
shErg.Activate
End Sub
Gruß, Daniel
die Änderungen im Code hab ich fett markiert.