Macro voor filteren tussen twee tijdspannes

[jonasparmentier]

Hallo,

Elke dag vraag ik een Excel bestand op uit een programma waar ik dan telkens alle rijen voor 20u00 moet verwijderen en daarna de rijen van na 05u00 de volgende dag. Met deze lijst moet ik dan een totaal berekenen van kolom K.

Graag had ik hiervan een macro gemaakt om dit te vergemakkelijken.

Eerst was ik al aardig ver gekomen, maar mijn macro werd zodanig groot (waarschijnlijk omdat ik veel te veel aparte stappen gebruikte) dat bij het uitvoeren telkens Excel blokkeerde en ik opnieuw moest opstarten en mijn formule was dan nog niet eens klaar

Ik ben al een aantal avonden bezig geweest met van alles te proberen, maar geraak er echt niet uit.

Ik maak mijn macro waarschijnlijk steeds te ingewikkeld of zo vrees ik...

Kan iemand mij helpen aub?


In bijlage het bestandje. de kolommen zijn elke dag hetzelfde, maar de rijen en datum niet.

Alvast bedankt!

jonas

 

[sylvester-ponte]

hallo Jonas, doe die macro van jouw er eens bij.

 

[HSV]

Waarom een Duits datumformaat?

 

[jonasparmentier]

Sub filter()
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1:A2000").Select
Dim CountY As Integer
Dim CountX As Integer
Dim chars As Integer
Dim tekst As String
Dim curChar As String
Dim stuk As String
Dim Spaces As Integer
Dim oCell As Range

'gaat iedere cel af in de selectie
For Each oCell In Selection
tekst = oCell.Text
CountY = oCell.Row
CountX = oCell.Column + 1
chars = Len(tekst)

For i = 1 To chars
curChar = Mid(tekst, i, 1)
If curChar <> " " Then
stuk = stuk + curChar

If Spaces > 0 Then
Spaces = Spaces - Spaces
End If

If i = chars Then
ActiveSheet.Cells(CountY, CountX).Value = stuk
stuk = String(0, 8)
End If

ElseIf curChar = " " Then
Spaces = Spaces + 1

If Spaces = 1 Then
ActiveSheet.Cells(CountY, CountX).Value = stuk
'raar maar waar, soms werd een cel in het vet gezet. Nu niet meer.
ActiveSheet.Cells(CountY, CountX).Font.Bold = False

CountX = CountX + 1
stuk = String(0, 8)
End If
Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$P$1208").AutoFilter Field:=3, Criteria1:= _
">=20:00:00", Operator:=xlAnd, Criteria2:="<=23:59:59"


End If
Next
Next
End Sub

 

[HSV]

Herstel je bericht door de code te selecteren en op de # te drukken bij geavanceerd.

 

[jonasparmentier]

Sub Jonas()
    With ActiveSheet.Range("A1").CurrentRegion
        .Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=DATEVALUE(SUBSTITUTE(LEFT(RC1,10),""."",""-""))+TIMEVALUE(RIGHT(RC1,8))"    'nieuwe kolom met omgerekende datum+tijdstip
        .Offset(, .Columns.Count + 1).Resize(, 1).FormulaR1C1 = "=--(MEDIAN(RC[-1],TRUNC(R2C[-1])+TIMEVALUE(""20:00:00""),TRUNC(R2C[-1])+1+TIMEVALUE(""5:00:00""))=RC[-1])"    'nieuwe kolom : bepalen tss 20:00 en volgende dag 5:00
        .Offset(, .Columns.Count).Resize(1, 2).Value = Array("tijdstip", "test")    'koptekst
    End With

    With ActiveSheet.Range("A1").CurrentRegion
        .AutoFilter                                                  'eventuele filter uitzetten
        .AutoFilter .Columns.Count, "=0"                             'filter foute tijdstippen
        .Resize(, 1).Offset(1).SpecialCells(xlVisible).EntireRow.Delete    'foute rijen verwijderen
        .Offset(, .Columns.Count - 2).Resize(, 2).EntireColumn.Delete    'laatste 2, net toegevoegde, kolommen wissen
        .AutoFilter                                                  'filter uitzetten
    End With

    With ActiveSheet.Range("A1").CurrentRegion
        .Offset(, .Columns.Count + 2).Resize(1, 1) = "sommeer"       'naast tabel deze tekst
        .Offset(, .Columns.Count + 3).Resize(1, 1) = WorksheetFunction.Sum(.Columns(.Columns.Count))    'er naast de som
    End With

End Sub

eigenlijk zou je niet hoeven de foute rijen te verwijderen, met een formule als Som.als of Sommen.als zou je ook al ver komen.

Hartstikke bedankt! Je bent een tovenaar