Doppelte anlisten

Sub DoppelteRaus() Application.EnableEvents = False Dim i As Integer, iRows As Integer, d d = 2 iRows = Cells(Cells.Rows.Count, 19).End(xlUp).Row For i = iRows To 1 Step -1 If WorksheetFunction.CountIf(Columns(19), Cells(i, 19)) > 1 Then Sheets("Prüflist").Cells(d, 3).Hyperlinks.Add Anchor:=Sheets("Prüflist"). _ Cells(d, 3), _ Address:="", SubAddress:="Tabelle1!" & Cells(i, 8).Address, _ TextToDisplay:="Tabelle1!" & Cells(i, 8).Address d = d + 1 End If Next i Application.EnableEvents = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
das Problem ist, daß die CountIF-Funktion immer versucht, Texte wenn möglich in Zahlen umzuwandeln.
nur leider ist bei Excel nach 15 stellen schluss, danach wird gerundet.
mögliche Abhilfe wären folgende:
1. du versiehst alle Materialnummern mit einen alphabetischen Zeichen oder dem Unterstrich, dann kann CountIF den Text nicht mehr in eine Zahl umwandeln und arbeitet richtig.
2. du sortierst deine Daten vorab nach der Materialnummer, dann kannst du die Doppelten durch einen Einfachen Vergleich mit der Zelle drüber und der Zelle drunter rausfinden.
das dürfte bei 10.000 Zeilen die Peformance des Makros auch deutlich verbessern, da die CountIF-Funktion sehr zeitintensiv ist.
(so als rechenbeispiel: die CountIf Funtkiton vergleicht den Wert mit allen Werten der Spalte, dh. wenn du alle Zeilen durchnudelst, hast du 10.000 x 10.000 Zellvergleiche, dh 100.000.000.
bei sortierten Daten musst du pro Schleifendurchlauf nur 2 Vergleiche durchführen, dh. du kommst auf 20.000 Zellvergleiche.)
Gruß, Daniel

Sub DoppelteRaus() Application.EnableEvents = False Dim i As Long, iRows As Long, d, vntTest, j As Long, iCounter As Long d = 2 iRows = Cells(Cells.Rows.Count, 19).End(xlUp).Row vntTest = Range(Cells(1, 19), Cells(iRows, 19)) vntTest = WorksheetFunction.Transpose(vntTest) For i = 1 To iRows iCounter = 0 For j = 1 To iRows If vntTest(i) = vntTest(j) Then iCounter = iCounter + 1 If iCounter > 1 Then Exit For Next j If iCounter > 1 Then Sheets("Prüflist").Cells(d, 3).Hyperlinks.Add Anchor:=Sheets("Prüflist"). _ Cells(d, 3), Address:="", SubAddress:="Tabelle1!" & Cells(i, 8).Address, _ TextToDisplay:="Tabelle1!" & Cells(i, 8).Address d = d + 1 End If Next i Application.EnableEvents = True End Sub

Sub DoppelteRaus() Application.EnableEvents = False Dim i As Long, j As Long, iRows As Long, d As Long, vntTest, iCounter As Long d = 2 iRows = Cells(Cells.Rows.Count, 19).End(xlUp).Row vntTest = Range(Cells(1, 19), Cells(iRows, 19)) vntTest = WorksheetFunction.Transpose(vntTest) For i = 1 To iRows If vntTest(i) "" Then iCounter = 0 For j = i + 1 To iRows If vntTest(i) = vntTest(j) Then iCounter = iCounter + 1 If iCounter > 1 Then Exit For Next j If iCounter > 1 Then Sheets("Prüflist").Cells(d, 3).Hyperlinks.Add Anchor:=Sheets("Prüflist"). _ Cells(d, 3), Address:="", SubAddress:="Tabelle1!" & Cells(i, 8).Address, _ TextToDisplay:="Tabelle1!" & Cells(i, 8).Address d = d + 1 End If End If Next i Application.EnableEvents = True End Sub

Hi
mit den Hyperlinks ist das natürlich schwierig, das verbietet natürlich das umsortieren.
da würde aber lieber die Werte der Doppelten in ein neues Blatt kopieren und dann ein kleines Makro,daß beim Anklicken den Autofilter entsprechend im Tabellenblatt setzt.
dann Fallen die Hyperlinks weg (ich finde die sowieso meist lästig)
aber auch wenn du Hyperlinks haben willst, kann man da u.U. schneller gestalten.
probier mal das Makro hier aus, ich konnte es mangels Daten leider nicht testen.
Funktionsweise ist so:
- orginalreihenfolge sichern
- daten Sortieren
- Doppelte Finden
- original-ZeilenNr der Doppelten in Prüfliste Schreiben
- Daten wieder zurücksortiern in alte Reihenfolge
- in Prüfliste Hyperlinks erstellen.
probiers mal aus, wenn nicht das erstellen der Hyperlinks der Zeitfresser ist, dann sollte das hier deutlich schneller sein.
Gruß, Daniel


Sub TestDoppelte()
Dim sp As Long, ze As Long
Dim Zelle As Range
With Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell)
sp = .Column + 1
ze = .Row
End With
With Sheets("Tabelle1")
'--- Originalreihenfolge sichern
With Range(.Cells(1, sp), .Cells(ze, sp))
.FormulaLocal = "=Zeile()"
.Formula = .Value
End With
'--- Doppelte finden
With Range(.Cells(2, sp + 1), .Cells(ze, sp + 1))
.FormulaLocal = "=WENN(S2="""";ZEILE();WENN(ODER(S2=S1;S2=S3);"""";ZEILE()))"
.Formula = .Value
.EntireRow.Sort , key1:=Cells(2, sp + 1), header:=xlNo
.SpecialCells(xlCellTypeBlanks).Offset(0, -1).Copy _
Destination:=Sheets("Prüflist").Range("C2")
End With
'--- Zurücksortieren
.UsedRange.Sort key1:=.Cells(1, sp), oder1:=xlAscending, header:=xlNo
.Columns(sp).Resize(, 2).Delete
End With
'--- Hyperlinks erzeugen
With Sheets("Prüflist")
Set Zelle = .Range("C2")
Do Until Zelle.Value = ""
ze = Zelle.Value
Zelle.Clear
.Hyperlinks.Add Anchor:=Zelle, Address:="", _
SubAddress:="Tabelle1!" & Cells(ze, 8).Address, _
TextToDisplay:="Tabelle1!" & Cells(ze, 8).Address
Loop
End With
End Sub

Beliebteste Forumthreads (12 Monate)

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread