filter

[pasan]

Hallo
waarom krijg ik van de 7 textbox waarden alleen de waarde van de laatste textbox in de listbox1?

Private Sub CommandButton4_Click()
 ActiveSheet.Unprotect Password:=""
 Application.ScreenUpdating = False

With [blad1!Bk1].CurrentRegion
   For I = 1 To 7
      With [blad1!BL1].CurrentRegion
      .AutoFilter 2, Me("Txtdatum" & I).Text
      .Copy [blad1!BT2].End(xlUp)
      .AutoFilter
    End With
 Next
         With [blad1!BT2].CurrentRegion
         ListBox1.List = .Value
        .ClearContents
    End With

End With

 Application.ScreenUpdating = True
 ActiveSheet.Protect Password:=""
End Sub

 

[HSV]

Zou het komen doordat je

BT2.end(xlup)

steeds overschrijft?

 

[pasan]

deze werkt ook niet

.Copy [blad1!BT2].End(xlUp).Offset(1, 0)

 

[pasan]

oke ik krijg nu alle datums in de listbox zonder kopieerslag
maar zelfs als ik andere datums in de textboxen heb staan komen alle datums uit kolom BL in de listbox

Private Sub CommandButton4_Click()
 ActiveSheet.Unprotect Password:=""
 Application.ScreenUpdating = False


With [blad1!Bk1].CurrentRegion
   For I = 1 To 7
      With [blad1!BL1].CurrentRegion
      .AutoFilter 2, Me("Txtdatum" & I).Text

    End With
 Next
         With [blad1!BL2].CurrentRegion
         ListBox1.List = .Value
        .AutoFilter
    End With
End With

 Application.ScreenUpdating = True
 ActiveSheet.Protect Password:=""
End Sub

 

[HSV]

En als je in je eerste code dit vervangt

.Copy [blad1!BT2].End(xlUp)

voor dit.

.Copy [blad1!BT65536].End(xlUp).offset(1)

 

[pasan]

nope helaas ook hier alleen de laatste textbox waarde
als ik met F8 alle stappen langsloop en de sheet in beeld hou dan zie ik dat elke datum die gevonden wordt vervangen wordt door de volgende zodat uiteindelijk alleen de laatste in beeld blijft en gekopieerd wordt

 

[HSV]

Doe dan je bestandje er eens bij als je wil.

 

[pasan]

bestand

http://www.mediafire.com/?b72fcknx083wzpx
deze is net over de 100 kb
ik denk dat je nog wel weet hoe deze form werkt

 

[HSV]

Zo moet het beter gaan.

Private Sub CommandButton3_Click()
 ActiveSheet.Unprotect Password:=""
 Application.ScreenUpdating = False
With [blad1!Bk1].CurrentRegion
   For I = 1 To 7
      With [blad1!BL1].CurrentRegion
      .AutoFilter 2, DateValue(Me("Txtdatum" & I))
    .Copy [blad1!BT65536].End(xlUp).Offset(1)
    End With

         With [blad1!BL2].CurrentRegion
         ListBox1.List = .Value
        .AutoFilter
    End With
     Next
End With
Application.ScreenUpdating = True
''ActiveSheet.Protect Password:=""
End Sub

 

[pasan]

HSV als je ook een 2e serie van 7 dagen opgeslagen hebt en deze 2e serie met de form weer ophaalt en dan hierna op de filterknop klikt dan komt niet alleen deze 7 dagen in de listbox maar alle eerdere datums ook

helaas voor nu moet ik ervandoor morgen ga ik hier mee verder bedankt zover HSV (ben dr al een hele week mee bezig)

 

[HSV]

Is het zo beter pasan?

 

[pasan]

helaas nadat ik de notatie in de kolom BL aangepast had naar "mm-dd-jjjj" werd er wel een datum gevonden maar alleen de datum van Txtdatum7 werd gekopieerd

ik ben de hele dag al bezig geweest om een andere manier te vinden om op 7 datums te filteren, wat ik gevonden heb is dat je dan beter kunt filteren tussen 2 datums, als ik nu in een cel de waarde zet van Txtdatum1 en in een andere de waarde van Txtdatum7 en dan deze 2 waarden kan gebruiken als >= dan range("BP4")(Txdatum1) en <= range("BQ4")(Txtdatum7)
ben bezig om met geavanceerd filteren een macro op te nemen

 

[HSV]

Nieuwe poging.

het schrijft nu alles weg naar blad2, en haalt het daar ook weer op voor de listbox.

 

[pasan]

Beste HSV deze werkt (zweet en tranen) dank je wel
Inmiddels heb ik echt vierkante ogen een sjaggerijnige vrouw maar het werkt.

ik durf het bijna niet te vertellen maar er zit nog 1 ding in wat dan niet goed gaat namelijk de voorwaardelijke opmaak in de rijen
3, 7, 11 enz omdat de datum notatie in kolom BL nu wel werkt voor het filter werkt het niet voor de voorwaardelijke opmaak.

ik wil je wel graag nog de manier die ik uiteindelijk ook werkend heb gekregen hier laten zien
met de volgende code zet ik de begindatum (Txtdatum1) in de cel
en de eind datum (Txtdatum7) in de cel

Private Sub UserForm_Activate()

Range("BP4") = format(DateValue(Txtdatum1), "mm-d-yy") 
Range("BQ4") = format(DateValue(Txtdatum7), "mm-d-yy")
' alleen even de nieuwe aanvulling hier neer gezet

end sub

met deze formule in Range("BP1") maak ik er >= dan Txtdatum1 van

=">="&(TEKST(BP4;"mm/d/jjjj"))

voor de Range("BQ1")

="<="&(TEKST(BQ4;"mm/d/jjjj"))

het filteren gebeurt dan zo

Private Sub CommandButton3_Click()
'' ActiveSheet.Unprotect Password:=""
 Application.ScreenUpdating = False
With ActiveSheet
  Range("BT2:BW100").ClearContents
    
    Range("BK1:BN52").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
        ("BP1:BQ2"), CopyToRange:=Range("BT1:BW1"), Unique:=False
    
     Range("BP4").ClearContents ' volgens mij moeten deze 2 leeggemaakt worden anders komen elke keer de zelfde waarden in de listbox1
     Range("BQ4").ClearContents
    ListBox1.List = [blad1!BT1].CurrentRegion.Value
   
End With
Application.ScreenUpdating = True
''ActiveSheet.Protect Password:=""

End Sub

om de datums uit gesorteerd in de listbox te krijgen

Private Sub UserForm_Activate()

    Columns("BL:BL").Select
    ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Blad1").Sort.SortFields.Add Key:=Range("BL1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Blad1").Sort
        .SetRange Range("BK2:BN52")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

 

[pasan]

aangepast

http://www.mediafire.com/?6u2dluetg84q20l

Het eindresultaat tot zover, de code zoals in mn vorige bericht verder aangepast, en het filteren op datums gaat naar mijn idee aardig snel

HSV ik wil je nogmaals bedanken voor je hulp en ondanks dat ik ff door de bomen het (VBA)bos niet meer zag is het uiteindelijk toch gelukt.
Ik heb er in iedergeval veel van geleerd, nu nog onthouden

De vraag gaat bij deze op opgelost en HSV nogmaals bedankt :thumb::thumb::thumb:


Ps. Ik heb de link zelf geprobeerd en ditmaal kon ik de map probleemloos openen