Lopslag med returnering af flere værdier (tekst)!

Er det for svært - eller måske bare umuligt??

Public Function SpecielOpslag(Kriterie As Range, Opslagsomrade As Range, ResultatKolonne) As String
Dim Fundet As Boolean, F_ad As Integer, S_ad As Integer
Fundet = False
omrade = Opslagsomrade
For I = 1 To UBound(omrade)
    If omrade(I, 1) = Kriterie Then
        F_ad = I
        Fundet = True
    End If
   
    If omrade(I, 1) <> Kriterie And Not IsEmpty(omrade(I, 1)) And Fundet Then
        S_ad = I - 1
        Exit For
    End If
  Next
If Fundet Then
For T = F_ad To S_ad
    SpecielOpslag = SpecielOpslag & " - " & omrade(T, ResultatKolonne)
Next
Else
    SpecielOpslag = "Ikke fundet"
End If
End Function

Kaldes med

=SPecielOpslag(D2;A2:B6;2)
D2 =cellen den skal sammenlignes med
A2:B6 = dataområdet
2 = kolonnen i området med resultaterne

den er ikke smuk, men virker ;-))

Ok, den ser sku vild ud... Men jeg er ikke helt så rutineret i brugen af koder, så hvor skal jeg sætte kodeteksten ind henne?

Højreklik på en arkfane, vælg vis programkode

Her i VBA editoren vælger du
Insert Module

kopier det ind på den hvide side du så ser

Det er sku liret!! Men er det ikke muligt at returnere tekstværdierne med ét navn på celle? Jeg skal nemlig kunne trække den enkelte sælger ud i en pivottabel på et senere tidspunkt...

Altså på forståeligt dansk: 1 navn til 1 celle!!!

Public Function SpecielOpslag(Kriterie As Range, Opslagsomrade As Range, ResultatKolonne) As Variant
Dim Fundet As Boolean, F_ad As Integer, S_ad As Integer, Temp() As Variant
Fundet = False
omrade = Opslagsomrade
For I = 1 To UBound(omrade)
    If omrade(I, 1) = Kriterie Then
        F_ad = I
        Fundet = True
    End If
       
   
    If omrade(I, 1) <> Kriterie And Not IsEmpty(omrade(I, 1)) And Fundet Then
        S_ad = I - 1
        Exit For
    End If
  Next
  I = (S_ad - F_ad) + 1
If Fundet Then
ReDim Temp(I) As Variant
I = 0
For T = F_ad To S_ad
    Temp(I) = omrade(T, ResultatKolonne)
    I = I + 1
Next
SpecielOpslag = Temp
Else
    SpecielOpslag = "Ikke fundet"
End If
End Function

Samme måde, men marker Lige så mange celler udad, som du kanforvente af sælgere, inden du skriver i cellen og slut af med CTRL+SHIFT ENTER, da det nu er en array function

der er lige rettet en fejl, hvis det var den sidste den fandt, opstod der en fejl.

Public Function SpecielOpslag(Kriterie As Range, Opslagsomrade As Range, ResultatKolonne) As Variant
Dim Fundet As Boolean, F_ad As Integer, S_ad As Integer, Temp() As Variant
Fundet = False
omrade = Opslagsomrade
For I = 1 To UBound(omrade)
    If omrade(I, 1) = Kriterie Then
        F_ad = I
        Fundet = True
    End If
       
   
    If omrade(I, 1) <> Kriterie And Not IsEmpty(omrade(I, 1)) And Fundet Then
      Exit For
    End If
  Next
  S_ad = I - 1
  I = (S_ad - F_ad) + 1
If Fundet Then
ReDim Temp(I) As Variant
I = 0
For T = F_ad To S_ad
    Temp(I) = omrade(T, ResultatKolonne)
    I = I + 1
Next
SpecielOpslag = Temp
Else
    SpecielOpslag = "Ikke fundet"
End If
End Function

Sejt at det virker!!! Men..... kan det ikke lade sig gøre at returnere værdierne nedad sådan det kommer til at se nogenlunde sådan her ud?

Kundenr      Sælger
4004        Svendt Bent
            Arne
            Børge
4005        Dan
            Kurt
4006        Peter

altså så sælgernes navn bliver returneret i cellerne nedad, og så resten af cellerne bliver rykket ned.... Kan man det?

ret
SpecielOpslag = Temp
til
SpecielOpslag = WorksheetFunction.Transpose(Temp)

så er de lodret

Kan jeg ikke få kundenummerne rykket ned, når den returnere sælgernes navne? jeg har en liste der ser således ud:

kundenr
4004
4005
4005

Vil gerne have den til at blive formateret på følgende måde med de returneret værdier:

kundenr                sælger
4004                  Svend
                      arne
                      kurt
4005                  dan
                      ib
4006                  johnny

med din ellers ret seje løsning kommer sælgerne til at blive returneret nedad uden man kan holde øje med hvilken sælger der hører til hvilken kunde.Jeg har nemlig 6500 kunder jeg skal have gjort det her ved.....

Det kan man ikke gøre med en Function, så skal du over i en makro.

Det var også derfor jeg satte dem på linie først

ok, kan du hjælpe mig lidt på vej til hvordan jeg så kan gøre det?

Det er ikke så let, når man ikke har arket.

Hvis du kan sende det til mig, bare en demo, jeg behøver ikke alle kunder.

Skriv så i arket , hvad du ønsker, så ser jeg på det.

kabbak snabela tiscali dot dk

har lige sendt filen til dig....

jeg kunne godt tænke mig ark 3 bliver returneret i samme opstilling som ark 1..

jeg prøver i aften

det lyder bare godt... takker mange gang for din hjælp!!

kunne du ikke bare  kopiere det fra ark1 direkte til  ark3

nej, det kan jeg ikke da de bliver samlet fra mange forskelige filer...

Vil lige høre om der er nyt i sagen??

jeg mente jeg havde sendt den, men her er koden

Sub Opdater()
Dim LKrow As Long, LDrow As Long, X As Long, T As Long
Dim Kriterie As Variant, ReadData As Variant
Dim Resultat(1000, 1) As Variant ' 1000 = antal forventede kunder*sælgere

' arket hvor der skrives i og hvor kriterier står i A kolonnen, startende i A1
LKrow = Worksheets("Ark3").Range("A65536").End(xlUp).Row
Kriterie = Worksheets("Ark3").Range("A1:A" & LKrow)

'Arket hvor data findes i 2 kolonner, her A og B
LDrow = Worksheets("Ark1").Range("A65536").End(xlUp).Row
ReadData = Worksheets("Ark1").Range("A1:B" & LDrow)
X = 0
Fundet = False
For L = 1 To UBound(Kriterie)

        For I = 1 To UBound(ReadData)
       
            If ReadData(I, 1) = Kriterie(L, 1) Then
            Fundet = True
              F_ad = I
            End If
           
            If ReadData(I, 1) <> Kriterie(L, 1) And Not IsEmpty(ReadData(I, 1)) And Fundet Then
              Exit For
            End If
          Next
         
     
   
    If Fundet Then
        S_ad = I - 1
        Resultat(X, 0) = Kriterie(L, 1)
          For T = F_ad To S_ad
            Resultat(X, 1) = ReadData(T, 2)
            X = X + 1
          Next
        Else
            Resultat(X, 0) = Kriterie(L, 1)
            Resultat(X, 1) = "Ikke fundet"
            X = X + 1
    End If
    Fundet = False
Next

' Arket hvor resultates skrives, her Ark3 B og C kolonnen
Worksheets("Ark3").Range("B2:C" & UBound(Resultat) + 2) = Resultat

End Sub

Cool... mange tak for det. Det virker sku helt perfekt!!!