AW: umbenenung von namen wenn doppelt
20.04.2006 23:51:10
namen
Hallo Selo,
hast Recht, da war noch ein Scherz drin. In der Zeile
Selection.PasteSpecial Paste:=xlPasteValues
taucht "Selection" auf - und damit werden die Zeilennummern kopiert in einen Bereich ab der zufällig aktiven Zelle. (War ein Relikt aus der Makroaufzeichnung.)
Hier noch mal die ganze Prozedur korrigiert:
Option Explicit
Sub Namen_eindeutig_3()
Dim anzZ&, rg As Range, zAnf&, zVgl&, erg%
Const Spal = 2
Const Head = xlNo
anzZ = Cells(Rows.Count, Spal).End(xlUp).Row
Columns(Spal).Insert Shift:=xlToRight
Columns(Spal).NumberFormat = "0"
With Range(Cells(1, Spal), Cells(anzZ, Spal))
.FormulaR1C1 = "=ROW()"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
If Head = xlYes Then Cells(1, Spal) = "Hilf"
Set rg = Range(Columns(Spal), Columns(Spal + 1))
rg.Sort Key1:=rg.Range("B1"), Order1:=xlAscending, Header:=Head, _
OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For zAnf = 1 - (Head = xlYes) To anzZ - 1
erg = 1
zVgl = 1
While Cells(zAnf, Spal + 1) = Cells(zAnf + zVgl, Spal + 1) And zAnf + zVgl <= anzZ
erg = erg + 1
Cells(zAnf + zVgl, Spal + 1) = Cells(zAnf + zVgl, Spal + 1) & "-" & CStr(erg)
zVgl = zVgl + 1
Wend
zAnf = zAnf + zVgl - 1
Next zAnf
rg.Sort Key1:=rg.Range("A1"), Order1:=xlAscending, Header:=Head, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns(Spal).Delete
Cells(1, Spal).Select
End Sub
Sub Namen_eindeutig_2()
Dim anzZ&, zAnf&, zVgl&, erg%
anzZ = Cells(Rows.Count, 1).End(xlUp).Row
Columns(1).Insert Shift:=xlToRight
Selection.NumberFormat = "0"
Range("A1").Select
Range(Cells(1, 1), Cells(anzZ, 1)).FormulaR1C1 = "=ROW()"
Range(Cells(1, 1), Cells(anzZ, 1)).Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Columns("A:B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=True, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For zAnf = 1 To anzZ - 1
erg = 1
zVgl = 1
While Cells(zAnf, 2) = Cells(zAnf + zVgl, 2) And zAnf + zVgl <= anzZ
erg = erg + 1
Cells(zAnf + zVgl, 2) = Cells(zAnf + zVgl, 2) & "-" & CStr(erg)
zVgl = zVgl + 1
Wend
zAnf = zAnf + zVgl - 1
Next zAnf
Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns(1).Delete
Cells(1, 1).Select
End Sub
Sub Namen_eindeutig()
Dim anzZ&, zAnf&, zVgl&, erg%
anzZ = Cells(Rows.Count, 1).End(xlUp).Row
For zAnf = 1 To anzZ - 1
erg = 1
For zVgl = zAnf + 1 To anzZ
If Cells(zAnf, 1) = Cells(zVgl, 1) Then
erg = erg + 1
Cells(zVgl, 1) = Cells(zVgl, 1) & "-" & CStr(erg)
End If
Next zVgl
Next zAnf
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort