binauf der suche nach einem VBA Script, welches mir doppelte Eintträge in einer Spalte findet und eine Spalte daneben ein "x" setzt
könnt ihr mir dabei bitte helfen
in C1 =WENN(ZÄHLENWENN(A:A;A1)>1;"x";"")
LG UweD
Sub XXXX()
Dim Sp As Integer, Z1 As Integer, LR As Integer
Sp = 1 'Spalte A
Z1 = 2 'Wegen Überschrift
With ActiveSheet
LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
With .Cells(Z1, Sp + 1).Resize(LR - Z1 + 1, 1)
.FormulaR1C1 = "=IF(COUNTIF(C[-1],RC[-1])>1,""x"","""")"
.Value = .Value
End With
End With
End Sub
Eingetragen wird in der Folgespalte
With ActiveSheet.Usedrange
With .Columns(.Columns.Count + 1)
.FormulaR1C1 = "= If(CountIf(C1,RC1)=1,"""",""x"")"
End With
End With
Das C1 steht hier für "Column 1" also Spalte A, für andere Spalten einfach die Nummer ändern
Option Explicit
Public Sub Dubletten_markieren()
Const SEARCH_COLUMN As Long = 1 'A
Dim objCell As Range
Dim objDictionary As Object
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With objDictionary
For Each objCell In Range(Cells(1, SEARCH_COLUMN), Cells(Rows.Count, SEARCH_COLUMN).End(xlUp))
If .Exists(Key:=objCell.Text) Then
objCell.Offset(0, 1).Value = "x"
.Item(Key:=objCell.Text).Offset(0, 1).Value = "x"
Else
Set .Item(Key:=objCell.Text) = objCell
End If
Next
End With
Set objDictionary = Nothing
End Sub
Gruß
Option Explicit
Public Sub Dubletten_markieren()
Const SEARCH_COLUMN As Long = 38 'A
Dim objCell As Range
Dim objDictionary As Object
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
With objDictionary
For Each objCell In Range(Cells(1, SEARCH_COLUMN), Cells(Rows.Count, SEARCH_COLUMN).End(xlUp))
If .Exists(Key:=objCell.Text) Then
objCell.Offset(0, 1).Value = "x"
.Item(Key:=objCell.Text).Offset(0, 1).Value = "x"
Else
Set .Item(Key:=objCell.Text) = objCell
End If
Next
End With
Set objDictionary = Nothing
End Sub
läuft einmal durch - aber es passiert sonst nichts
Sub XXXX()
Dim Sp As Integer, Z1 As Integer, LR As Integer
Sp = 9 'Spalte A
Z1 = 2 'Wegen Überschrift
With ActiveSheet
LR = .Cells(.Rows.Count, Sp).End(xlUp).Row 'letzte Zeile der Spalte
With .Cells(Z1, Sp + 1).Resize(LR - Z1 + 1, 1)
.FormulaR1C1 = "=IF(COUNTIF(C[-1],RC[-1])>1,""x"","""")"
.Value = .Value
End With
End With
End Sub
Const SEARCH_COLUMN As Long = 9 'I
Gruß
=ZÄHLENWENN($A:$A;$A1)>1
- Format festlegenArbeitsblatt mit dem Namen 'Tabelle1' | |
A | |
1 | Aaa |
2 | sds |
3 | ss |
4 | sds |
5 | Aaa |
6 | 1 |
7 | 2 |
8 | 3 |
9 | 1 |
10 | 2 |
11 | ww |
Zelle | bedingte Formatierung... | Format |
A1 | 1: ZÄHLENWENN($A:$A;$A1)>1 | abc |
Sub Unit_Duplicates()
Dim C As Range, O As Object
With Columns(38)
If Application.CountA(.Cells) = 0 Then Exit Sub
Set O = CreateObject("scripting.dictionary")
For Each C In .SpecialCells(2)
If O.Exists(C.Text) Then
C.Offset(0, 1) = "X"
Else
O.Add Key:=C.Text, Item:=0
End If
Next
End With
O.RemoveAll: Set O = Nothing
End Sub
Gruß Gerd