Waarden filteren en daarna transponeren

[Yasmin]

Beste Excellers,

Ik zoek een formule voor cel R44/of VBA code zie bijlage.

Ik heb een werkmap met ca. 150 werkbladen met 4 tabellen per blad.
Nu wil ik de tijden uit kolom I (I6:I11)+(I16:I21)+(I26:I31)+(I36:I41) waar een waarde(cijfer of teken) in kolom H voor staat selecteren.
Daarna sorteren van laag naar hoog (7u - 24u), filteren op unieke waarden, de letter "u" eraf halen en transponeren naar cel R44 en het woord "uur" erachter zetten.
Wie kan mij hiermee helpen?

Met vriendelijke groet,

Yasmin


Bekijk bijlage Selecteren en filteren.xlsx

 

[WHER]

Een aanpak met formules, zie bijlage.
Het lijkt mij echter dat dit beter in VBA zou gedaan worden.

 

[Roncancio]

Bij een wijziging in de H-kolom worden de gevonden waardes in cel R44 geplaatst.

Met vriendelijke groet,


Roncancio

 

[Yasmin]

WHER en Roncancio,

Beide oplossingen werken maar zoals WHER adviseert kies ik voor de oplossing via VBA van Roncancio. Beide heel hartelijk dank voor het meedenken!
Ik kan nog veel van jullie leren.

Met vriendelijke groet,

Yasmin

 

[Yasmin]

Roncancio,

Ik kom erachter dat onderstaande code niet werkt in een beveiligd werkblad.
Na wat zoeken op het forum lees ik dat ik ergens ? UserInterfaceOnly=True moet zetten dan lukt het wel.
Waar moet dit staan in de code?

Met vriendelijke groet,

Yasmin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then
Dim Arr(10) As Variant
Dim iAr As Integer
Dim lRij As Long
Dim vSep As Variant
Dim iBgn As Integer
Dim iEnd As Integer
Dim iTel As Integer

For lRij = 1 To 41
If Range("H" & lRij).Value <> "" Then
vSep = Chr$(1)
With Range("I" & lRij)
If InStr(1, vSep & Join(Arr, vSep) & vSep, vSep & Left(.Value, Len(.Value) - 1) & vSep, 1) = 0 Then
Arr(iAr) = Left(.Value, Len(.Value) - 1)
iAr = iAr + 1
End If
End With
End If
Next
For iBgn = 0 To UBound(Arr()) - 1
For iEnd = iBgn + 1 To UBound(Arr())
If Val(Arr(iBgn)) > Val(Arr(iEnd)) And Val(Arr(iEnd)) > 0 Then
iTmp = Arr(iBgn)
Arr(iBgn) = Arr(iEnd)
Arr(iEnd) = iTmp
End If
Next
Next

For iTel = 0 To UBound(Arr)
If Arr(iTel) > "" Then List = List & Arr(iTel) & " - "
Next
Range("R44").Value = Left(List, Len(List) - 2) & " uur"
End If
End Sub

 

[Roncancio]

UserInterfaceOnly=True gebruik je bij het beveiligen van het werkblad via VBA.
Voorbeeld:

Private Sub Workbook_Open()
Sheets(1).Protect "helpmij", UserInterfaceOnly = True
End Sub

Bij het openen van het bestand wordt het 1e werkblad beveiligd met het wachtwoord helpmij.

Bovenstaande code hoort overigens bij ThisWorkbook.

Met vriendelijke groet,


Roncancio

 

[Yasmin]

Roncancio,

De vraag was: "Ik wil de tijden uit kolom I (I6:I11)+(I16:I21)+(I26:I31)+(I36:I41) waar een waarde(cijfer of teken) in kolom H voor staat selecteren".
Daarna sorteren van laag naar hoog (7u - 24u), filteren op unieke waarden, de letter "u" eraf halen en transponeren naar cel R44 en het woord "uur" erachter zetten.

De code die je gemaakt hebt werkt heel mooi, maar ik kom erachter door alles goed uit te testen dat er in bepaalde omstandigheden een foutmelding ontstaat nl. als in kolom I geen tijd is ingevuld en er per abuis in kolom H een waarde wordt gezet.
Ik had in mijn vraag duidelijk aan moeten geven dat niet altijd in kolom I een tijd staat.
Kun je a.u.b. nog eens kijken naar de code om zodoende de foutmelding te voorkomen?

Met vriendelijke groet,

Yasmin

 

[Roncancio]

Volgens mij klopt het zo beter.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then
    Dim Arr(10) As Variant
    Dim iAr As Integer
    Dim lRij As Long
    Dim vSep As Variant
    Dim iBgn As Integer
    Dim iEnd As Integer
    Dim iTel As Integer
        On Error Resume Next
        For lRij = 1 To 41
            If Range("H" & lRij).Value <> "" And Range("I" & lRij) <> "" Then
                vSep = Chr$(1)
                With Range("I" & lRij)
                    If InStr(1, vSep & Join(Arr, vSep) & vSep, vSep & Left(.Value, Len(.Value) - 1) & vSep, 1) = 0 Then
                        Arr(iAr) = Left(.Value, Len(.Value) - 1)
                        iAr = iAr + 1
                    End If
                End With
            End If
        Next
        For iBgn = 0 To UBound(Arr()) - 1
            For iEnd = iBgn + 1 To UBound(Arr())
                If Val(Arr(iBgn)) > Val(Arr(iEnd)) And Val(Arr(iEnd)) > 0 Then
                    iTmp = Arr(iBgn)
                    Arr(iBgn) = Arr(iEnd)
                    Arr(iEnd) = iTmp
                End If
            Next
        Next
    
        For iTel = 0 To UBound(Arr)
            If Arr(iTel) > "" Then List = List & Arr(iTel) & " - "
        Next
        Range("R44").Value = Left(List, Len(List) - 2) & " uur"
End If
End Sub

Met vriendelijke groet,


Roncancio

 

[Yasmin]

Roncancio,

Met deze code gaat het helemaal perfect!
Hartelijk dank.

Met vriendelijke groet,

Yasmin