VBA - Unikke værdier

Prøv at Uploade et eksempel - alternativt sende det - @-adresse under min profil.

Hej

Prøv nedenstående procedure.

Sub Unikke()

Dim lCount As Long
Dim rInput As Range
Dim rCell As Range
Dim colOrd As New Collection
Dim colRemove As New Collection

Set rInput = Range("F23:F32,D37:D43")

On Error Resume Next

'Ordene føjes til en collection med nøgle.
'Hvis det allerede forekommer, føjes ordet
'til en anden collection, colRemove.
For Each rCell In rInput
  If IsEmpty(rCell) = False Then
      colOrd.Add rCell.Value, rCell.Value
      If Err.Number = 457 Then
        colRemove.Add rCell.Value, rCell.Value
        Err.Number = 0
      End If
  End If
Next

'colRemove indeholder evt. dubletter, og vi
'gennemløber colRemove og fjerner dubletterne
'fra colOrd
If colRemove.Count > 0 Then
  For lCount = 1 To colRemove.Count
      colOrd.Remove colRemove.Item(lCount)
  Next
End If

'Nu gennemløbes de unikke værdier i colOrd,
'og de indsættes i celle C46 og mod højre.
'Hvis der er mere end 8 unikke ord, kommer
'en msgbox, og løkken afbrydes.
If colOrd.Count > 0 Then
  For lCount = 1 To colOrd.Count
      If lCount > 8 Then
        MsgBox "Der er mere end 8 unikke ord"
        GoTo BeforeExit
      End If
      Range("C46").Offset(0, lCount - 1).Value = colOrd.Item(lCount)
  Next
End If

BeforeExit:
Set colOrd = Nothing
Set colRemove = Nothing
Set rCell = Nothing
Set rInput = Nothing

End Sub

Hej Sitestory

Det er noget af det rigtige, men det er nok mig der har formuleret mig forkert.

Det er alle værdierne jeg gerne vil have listet, men kun en gang, således dubletterne kun fremgår en gang eks.

F23 til F32
A
B
C
B
A

D37 til D43
C
F
E
A

Bliver til
C46 og frem til J46
A B C E F

Det forenkler jo sagen :-) Så skulle nedenstående være nok:

Sub Unikke()

Dim lCount As Long
Dim rInput As Range
Dim rCell As Range
Dim colOrd As New Collection

Set rInput = Range("F23:F32,D37:D43")

On Error Resume Next

'Ordene føjes til en collection med nøgle.
'Det sikrer, at ord kun tilføjes én gang.
For Each rCell In rInput
  If IsEmpty(rCell) = False Then
      colOrd.Add CStr(rCell.Value), CStr(rCell.Value)
  End If
Next

If colOrd.Count > 0 Then
  For lCount = 1 To colOrd.Count
      If lCount > 8 Then
        MsgBox "Der er mere end 8 unikke ord"
      End If
      Range("C46").Offset(0, lCount - 1).Value = colOrd.Item(lCount)
  Next
End If

BeforeExit:
Set colOrd = Nothing
Set rCell = Nothing
Set rInput = Nothing

End Sub

Tak skal du have. Det fungerer perfekt. Skriver du et svar.

Hej igen

Jeg får nu en fejl i linjen

Set rInput = Range("F23:F32,D37:D43")

Det kom til at virke efter genstart af computeren

Det var godt :-)