VBA: Håndtering af dubletter i tekster (tilføj løbenummer)

Glemte lige en ting der nok gør det lidt mere svært: Listen må ikke sorteres - den skal beholde sin originale rækkefølge.

har ikke testet, men hvis du kan benytte en makro, prøv denne
Denne sjekker i kolonne A, rad 5 til 100, dette endrer du lett selv

Sub DublettListe()
i = 1 
For Each c In [A5 : A100]
    For Each t In [A5 : A100]
      If t.Value = c.Value And Not t.Value = "" Then
        t.Value = c.Value & i
        i = i +1
      End If
    Next
  Next
End Sub

den forrige var feil, prøv denne

Sub DublettListe()

For Each c In [A5 : A100]
    i = 1
    For Each t In [A5 : A100]
      If t.Value = c.Value And Not t.Value = "" Then
        t.Value = c.Value & i
        i = i +1
      End If
    Next
  Next
End Sub

Den tilføjer 1 til alle rækker, og ikke 2 eller 3 til de rækker hvor det er nødvendigt!?

ja noe er feil, jeg leter febrilsk :-)

Du kunne også indsætte denne formel, kopier den helt ned og bagefter kopiere og indsætte dette hele som værdier
Går ud fra at tabellen er i kolonne A

=A2 & HVIS(TÆL.HVIS($A$2:A2;A2)-1>0;" ("&TÆL.HVIS($A$1:A2;A2)-1&")";"")

Sorry, så ikke lige at det var et VBA-spørgsmål

hei bak!
kan du se hvor feilen ligger i mitt forslag?

dette var en hard nøtt

Den først celle den sjekker er A5 og den siste A100  ( r )
det har ikke noe å si om r er større enn siste rad med data
( håper du forstår mitt språk (norsk),  god helg  ;-)



Sub DublettListe()
  r = 100
  For Each c In Range(Cells(5, 1), Cells(r, 1))
    For Each t In Range(Cells(5, 1), Cells(r, 1))
      If c.Row < t.Row And t.Text = c.Text And Not t.Value = "" Then
        i = i + 1
        t.Value = t.Text & " (" & i & ")"
      End If
      If t.Row = r Then i = 0
  Next
Next
End Sub

Sub DublettListe()
Dim rng As Range
Dim c As Range
Dim t As Range
Dim i As Long

Set rng = [A5:A100]
  For Each c In rng
      temp = c.Value
      i = 0
      For Each t In rng
        If t.Value = temp And Not t.Value = "" Then
            If i > 0 Then t.Value = temp & " (" & i & ")"
            i = i + 1
        End If
      Next
  Next
End Sub

oyejo--> hey, så ikke at du havde svaret på dit eget spørgsmål
Du er ved at blive hård :-)

hei bak!
det er jo du som har lært meg det meste ;-)
En god helg til deg også !!
oye

oyejo -> god weekend :-)

snowball skriver:
Hvordan gør jeg det nemmest og ikke mindst effektivt
da der godt kan være ca. 1.000 tekster!

jeg laget en liste på ca 1300 tekster, der det kunne være over 100 like tekster.
Når jeg testet bak's kode mot mitt forslag, var bak's kode 4 x hurtigere.

Prøvde derfor å laste alle tekstene i en Array.
For så å gjøre operasjoenen på selve Arrayet.


Public Sub Duplicatverdier()
 
 
  Dim c As Long, t As Long, i As Long, x As Long
  Dim vTab() As Variant
  Dim fRow As Long 'first row
  Dim lRow As Long 'last row
 
 
  fRow = 5 'first row
  lRow = Cells(Rows.Count, 1).End(xlUp).Row
  vTab = Range(Cells(fRow, 1), Cells(lRow, 1))
 
  For c = 1 To UBound(vTab) - 1
    i = 1: x = c + 1
    For t = x To UBound(vTab)
      If Not vTab(t, 1) = "" And vTab(t, 1) = vTab(c, 1) Then
        vTab(t, 1) = vTab(t, 1) & " (" & i & ")"
        i = i + 1
      End If
    Next
  Next
 
  Range(Cells(fRow, 1), Cells(lRow, 1)) = vTab
 
End Sub

den ble ca. 25 x raskere enn bak's kode.

Men kjenner jeg bak rett, kan han gjøre den ennå mye mere effektiv ;-)
Kanskje man kan lage en liste med unike verdier, for så å teste mot den?
Eller en collection, der man benytter remove på hver tekst som alt er benyttet?

Jeg venter spent ;o)

oyejo -> Du har lavet koden næsten optimalt, så der er ikke meget at hente her :-)
Flot kode, jeg kan se at du har fået greb om array-operationerne og du læser ikke hele arrayet igennem i din anden løkke, god detajle her.
Hvis jeg bruger 3000 linier og min tudsegamle 1200 mhz computer tager din kode 4 sek.
Hvis du ændrer koden lidt således at sætningen 
If Not vTab(t, 1) = "" And vTab(t, 1) = vTab(c, 1) Then
kun chekker for en ting og kun hvis dette er sandt chekker for, om den er blank tager det kun 2 sek.

For c = 1 To UBound(vTab) - 1
      i = 1: x = c + 1
      For t = x To UBound(vTab)
        If vTab(t, 1) = vTab(c, 1) Then
            If Not IsEmpty(vTab(t, 1)) Then
              vTab(t, 1) = vTab(t, 1) & " (" & i & ")"
              i = i + 1
            End If
        End If
      Next
  Next

skulle da lige teste med collection. Tid 0,65 sek
Public Sub DuplicatverdierCollection()
Dim i As Long, x As Long
Dim xcol As New Collection
Dim vTab() As Variant
Dim fRow As Long                                      'first row
Dim lrow As Long
Dim elem
Dim it

  fRow = 2                                          'first row
  lrow = Cells(Rows.Count, 1).End(xlUp).Row
  vTab = Range(Cells(fRow, 1), Cells(lrow, 1))
  On Error Resume Next
  For Each elem In vTab
      xcol.Add elem, elem
  Next
  On Error GoTo 0

  For Each it In xcol
      i = 0
      For x = 1 To UBound(vTab, 1)
        If vTab(x, 1) = it Then
            If Not i = 0 Then
              vTab(x, 1) = vTab(x, 1) & " (" & i & ")"
            End If
            i = i + 1
        End If
      Next
  Next
  Range(Cells(fRow, 1), Cells(lrow, 1)) = vTab

End Sub

bak -> FANTASTISK
denne koden skal jeg bruke mye tid på.
Du skulle hatt 60 point fra meg også :-)

Mange tak for hjælpen :)

Lav venligst begge et svar.

bak har fortjent alle pointene.

vi to har fått noe som er mye mere verdt en points :-)

Ja, jeg må sige at jeg også lærte noget ved dette spørgsmål :)

Tak for rosen. jeg vil gerne dele med oyejo, da jeg synes han har lavet et godt dtykke arbejde med denne kode :-)

oyejo: Er du sikker på du ikke vil have nogle point?

Dere dansker er nå så hyggelige :-)
Men det er ikke rigtig at jeg får like mye point som bak.
Kan ikke jeg få 10 points og bak 50?

ups, har jeg lært å glemme å svare av deg også bak? ;o)

Sådan - så fik I begge point.

Tak for hjælpen :)