Unieke waarden uit range filteren

[Rubman]

Ik heb een Excel met personeelsplanning per productie lijn en nu wil ik de unieke waarden van verschillende uitzendbureaus BT en PM eruit filteren en in een nieuwe kolom zetten. Dit om te kijken welke uitzenders we inzetten en dit door te geven aan de desbetreffende bureaus, namen wisselen nogal.

Moeten dus 2 kolommen worden met 1 kolom 1 de unieke waarden beginnend met BT en kolom 2 Unieke waarden beginnend met PM.

Kan iemand hier mee helpen?

Bekijk bijlage Copy of Voorbeeld personeelsplanning.xlsx

 

[spaarie]

Dubbelklik in bijgevoegd bestand op de blauwe BT/PM cel en de unieke uitzendkrachten komen eronder te staan.

 

[Rubman]

Bedankt dit scheelt al iets idd, maar ik zoek het dus meer richting 2 aparte tabellen met in 1 blauwe uitzenders en in de andere alle paarse.
Nu filtert hij enkel uit alle rijden erboven.

Had dus zelf al inderdaad een begin gemaakt met het filteren vanuit de rijen erboven, maar kwam niet tot 1 tabel maar alsnog alles door elkaar.

 

[Warme bakkertje]

Wat denkt ge van deze?

Sub tst()
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    sn = Sheets("Blad1").UsedRange.Value
    For i = 1 To UBound(sn)
        For ii = 1 To UBound(sn, 2)
            If Left(sn(i, ii), 2) = "BT" Then x0 = dic1.Item(sn(i, ii))
            If Left(sn(i, ii), 2) = "PM" Then x0 = dic2.Item(sn(i, ii))
        Next
    Next
    Sheets("Blad1").Cells(1, 11).Resize(dic1.Count) = Application.Transpose(dic1.keys)
    Sheets("Blad1").Cells(1, 12).Resize(dic2.Count) = Application.Transpose(dic2.keys)
    Set dic1 = Nothing
    Set dic2 = Nothing
End Sub

 

[Ginger]

Ik heb het bestand niet bekeken (kijk nu op m'n tablet), maar het klinkt mij heel veel naar een gevalletje "draaitabel"...

 

[Rubman]

Wat denkt ge van deze?

Sub tst()
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    sn = Sheets("Blad1").UsedRange.Value
    For i = 1 To UBound(sn)
        For ii = 1 To UBound(sn, 2)
            If Left(sn(i, ii), 2) = "BT" Then x0 = dic1.Item(sn(i, ii))
        Next
    Next
    For i = 1 To UBound(sn)
        For ii = 1 To UBound(sn, 2)
            If Left(sn(i, ii), 2) = "PM" Then x0 = dic2.Item(sn(i, ii))
        Next
    Next
    Sheets("Blad1").Cells(1, 11).Resize(dic1.Count) = Application.Transpose(dic1.keys)
    Sheets("Blad1").Cells(1, 12).Resize(dic2.Count) = Application.Transpose(dic2.keys)
    Set dic1 = Nothing
    Set dic2 = Nothing
End Sub

Hier kan ik mee werken, thx.

Ga hem aanpassen om in het volledige bestand en bestaande macro's werkend te krijgen. en het BT/PM onderaan de planning er weer uit slopen:thumb: