Vise een kunde med mange kundenr. i dropdownliste.

Denne Kode laver en liste hvor navnet kun forkommer engang


Sub navnengang()
 
  Dim Rng1 As Range
  Dim rstart1 As Range

    Set rstart1 = ActiveSheet.Range("A1")
    Set Rng1 = Range(rstart1.Offset(0, 0), Cells(1000, rstart1.Column).End(xlUp))
       
    MarkDuplicates Rng1

End Sub


Private Sub MarkDuplicates(rlist As Range)
Dim Cell As Range
Dim Uniqs As Object 'New Dictionary
Set Uniqs = CreateObject("scripting.dictionary")
  Application.ScreenUpdating = False
  On Error Resume Next
  t = 0
  res = "D"
  For Each Cell In rlist
      Uniqs.Add UCase(Cell.Value), CStr(UCase(Cell.Value))
      If Err.Number = 0 And Cell.Value <> Empty Then
        Cells(t, res) = Cell.Value
        t = t + 1
      End If
      Err.Clear
  Next Cell
 
End Sub

Pyha den driller mig, jeg kan ikke få sat koden ind det rigtige sted, min kode ser sådan ud uden din nye kode:

Private Sub Worksheet_Activate()
    Set was = ActiveSheet
    Set wb = Workbooks.Open("C:\Kunder.xls")
    For i = 1 To 500
        was.Range("R" & i).Value = wb.Sheets(1).Range("E" & i).Value
        was.Range("N" & i).ClearContents
        If IsEmpty(wb.Sheets(1).Range("E" & i)) = False Then
            was.Range("N" & i).Value = wb.Sheets(1).Range("E" & i).Value & "-" & wb.Sheets(1).Range("a" & i).Value
        End If
    Next
    wb.Close
    was.Range("N2:R999").Sort _
    Key1:=was.Range("R2:R999"), _
        Header:=xlGuess

    Worksheets(1).EnableCalculation = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Worksheets(1).EnableCalculation = True Then
        Worksheets(1).EnableCalculation = False
        If ActiveCell.Column = 2 Then
            Set was = ActiveSheet
            was.Range("C" & ActiveCell.Row).ClearContents
            j = 2
            For i = 2 To 500
                ac = ActiveCell.Value
                was.Range("P" & i).ClearContents
                If was.Range("R" & i).Value = ac Then
                    was.Range("P" & j).Value = was.Range("N" & i).Value
                    j = j + 1
                End If
            Next
        End If
        Worksheets(1).EnableCalculation = True
    End If
End Sub

Hvilken kolonne er det du vil have liste, N,R eller P

Kan du evt sende arket?

Jacob,lemming(a)honeywell,com
,=.
(a)= @

Hej Jacob,
De to kolonner som der er i Kunder.xls er A og E som jeg tager med over i Oversigt.xls, det er der hvor jeg har dropdown listerne.

Kolonne R, N og P er i Oversigt.xls :

Kolonne R er den kolonne hvor jeg får alle kundenavnene over i fra Kunder.xls.
Kolonne N inderholder kundenavnene + sagsnumre som jeg fletter sammen.
Kolonne P er der hvor jeg får vist alle sagsnumrene inde for den valgte kunde.

Jeg glemte at skrive at jeg ikke kan sende fra min mail i øjeblikket...

Denne opretter en liste i kolonne O, jeg forventer at der ikke må slettes i din tabel, så du er nød til at oprette en ny.
koden skal kaldes således


call navnengang
Worksheets(1).EnableCalculation = True
end sub



Sub navnengang()
 
Dim Rng1 As Range
Dim rstart1 As Range
Dim Cell As Range
Dim Uniqs As Object 'New Dictionary

Set rstart1 = ActiveSheet.Range("R2")
Set Rng1 = Range(rstart1.Offset(0, 0), Cells(1000, rstart1.Column).End(xlUp))
Set Uniqs = CreateObject("scripting.dictionary")
rstart2 = 0 'start række resultat
cstart2 = "O" 'kolonne for resultat
Application.ScreenUpdating = False
  For Each Cell In Rng1
      Uniqs.Add UCase(Cell.Value), CStr(UCase(Cell.Value))
      If Err.Number = 0 And Cell.Value <> Empty Then
        Cells(rstart2, cstart2) = Cell.Value
        rstart2 = rstart2 + 1
      End If
      Err.Clear
  Next Cell
Application.ScreenUpdating = True
End Sub

Hej, jeg desværre ikke få den til at virke, det er vist ikke liiiige min dag ;-) jeg har sendt en mail til dig med Excel filerne. Bare når du har tid.

Hej Brian

Har du fået kigget på den mail jeg sendte retur

velbekomme

lukketid ?

Husk at accepter svaret, vælg mit navn i nedeste venstre hjørne og tryk accepter

Sorry, det havde jeg helt svedt ud :o) og endnu engang tak for hjælpen.