Probleempje met de macro

[gl3nn1987]

Sub KOPIEEREN()
    Dim c      As Range
    y = 2
    [Factuur!A3].CurrentRegion.ClearContents
    For Each c In Sheets("Agenda").Range("A2:G2000")
        If c = [Agenda!J3] And c >= [Agenda!J1] And c <= [Agenda!L1] Then
            Sheets("Factuur").Range("A" & y).Offset(1, 0) _
                .Resize(, 5) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 5).Value
            y = y + 1
       End If
       Next
End Sub

Nu heb ik in J1 en L1 datums staan die doet hij afzonderlijk van de voorwaarde in J3 goed. Het probleem is dat ik ze zo niet bij elkaar werken maar afzonderlijk wel. Maar hij moet dus en binnen de aangegeven datums functioneren en de voorwaarde dat de teskt in kolom G gelijk is aan die in J3 (beide dezelfde dropdownmenu's)

 

[gl3nn1987]

Sub KOPIEEREN()
Call KOPIEEREN1
Call KOPIEEREN2
End Sub
Sub KOPIEEREN1()
    Dim c      As Range
    y = 2
    [Factuur!A3].CurrentRegion.ClearContents
    For Each c In Sheets("Agenda").Range("A2:A2000")
        If c >= [Agenda!J1] And c <= [Agenda!L1] Then
            Sheets("Factuur").Range("A" & y).Offset(1, 0) _
                .Resize(, 7) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 7).Value
            y = y + 1
       End If
       Next
End Sub
Sub KOPIEEREN2()
    Dim c      As Range
    y = 2
    [Factuur2!A3].CurrentRegion.ClearContents
    For Each c In Sheets("Factuur").Range("G2:G2000")
        If c = [Agenda!J3] Then
            Sheets("Factuur2").Range("A" & y).Offset(1, 0) _
                .Resize(, 5) = Sheets("Factuur").Cells(c.Row, 1).Resize(, 5).Value
            y = y + 1
       End If
       Next

End Sub

Zo werkt hij wel maar ik wil dus maar 1 tabblad factuur niet een tussenblad voor de berekening.

 

[Warme bakkertje]

Sub KOPIEEREN1()
    Dim c      As Range
    y = 2
    [Factuur!A3].CurrentRegion.ClearContents
    For Each c In Sheets("Agenda").Range("A2:A2000")
        If c >= [Agenda!J1] And c <= [Agenda!L1] And c.Offset(, 6) = [Agenda!J3] Then
            Sheets("Factuur").Range("A" & y).Offset(1, 0) _
                .Resize(, 7) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 7).Value
            y = y + 1
       End If
       Next
End Sub

 

[gl3nn1987]

Thanks nog 1 klein vraagje weetje hoe ik automatisch een regel erbij krijg die de gegevens optelt

dus totaal van kolom c en e wat zojuist gekopieerd is?

 

[Warme bakkertje]

Sub KOPIEEREN1()
    Dim c      As Range
    y = 2
    With Sheets("Factuur")
        .[A3].CurrentRegion.ClearContents
        For Each c In Sheets("Agenda").Range("A2:A" & Sheets("Agenda").Cells(Rows.Count, 1).End(xlUp).Row)
            If c >= [Agenda!J1] And c <= [Agenda!L1] And c.Offset(, 6) = [Agenda!J3] Then
                .Range("A" & y).Offset(1, 0).Resize(, 7) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 7).Value
                y = y + 1
            End If
       Next
    .Range("C65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("C3:C" & [COLOR="red"].[/COLOR]Cells(Rows.Count, 3).End(xlUp).Row))
    .Range("E65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("E3:E" & [COLOR="red"].[/COLOR]Cells(Rows.Count, 5).End(xlUp).Row))
    End With
End Sub

 

[gl3nn1987]

Hij werkt weer perfect. Alleen mist hij nog de tekst totaal in kolom B en die hele rij vetgedrukt in kolom B en hoe krijg ik de Kop mee gekopieerd inclusief opmaak. (A1:E1)

 

[Warme bakkertje]

Ik denk dat je best je bestandje eens plaatst want het wordt anders gokken. Heb trouwens nog een aanpassing gedaan aan de macro in Post#5

 

[gl3nn1987]

Bekijk bijlage test.xls

 

[Warme bakkertje]

Sub KOPIEEREN1()
    Dim c      As Range
    y = 2
    With Sheets("Factuur")
        With .[A3].CurrentRegion
            .ClearContents
            .Font.FontStyle = "Standaard"
        End With
        For Each c In Sheets("Agenda").Range("A2:A" & Sheets("Agenda").Cells(Rows.Count, 1).End(xlUp).Row)
            If c >= [Agenda!J1] And c <= [Agenda!L1] And c.Offset(, 6) = [Agenda!J3] Then
                .Range("A" & y).Offset(1, 0).Resize(, 5) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 5).Value
                y = y + 1
            End If
        Next
    With .Range("B65536").End(xlUp)
        .Offset(1) = "Totaal"
        .Offset(1).Resize(, 4).Font.FontStyle = "Bold"
    End With
    .Range("C65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("C3:C" & .Cells(Rows.Count, 3).End(xlUp).Row))
    .Range("E65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("E3:E" & .Cells(Rows.Count, 5).End(xlUp).Row))
    End With
End Sub

Wat betreft de Kop, die plaats je toch 1-malig en wijzigt daarna toch niet meer ?

 

[gl3nn1987]

Ja maar ik wil hem tevens doorsturen naar apart Workbook. En uiteindelijk ook nog in WORD vandaar..

ik kan nog echt heel weinig zelf met macro's dus ik doe het stapje voor stapje zo dat ik tenminste snap wat ik aangeleverd krijg

 

[Warme bakkertje]

Sub KOPIEEREN1()
    Dim c      As Range
    y = 2
    With Sheets("Factuur")
        With .[A1].Resize(, 5)
            .Value = Split("Datum|Omschrijving werkzaamheden|Uren|Tarief|Bedrag", "|")
            .Font.FontStyle = "Bold"
            .Interior.ColorIndex = 44
        End With
        With .[A3].CurrentRegion
            .ClearContents
            .Font.FontStyle = "Standaard"
        End With
        For Each c In Sheets("Agenda").Range("A2:A" & Sheets("Agenda").Cells(Rows.Count, 1).End(xlUp).Row)
            If c >= [Agenda!J1] And c <= [Agenda!L1] And c.Offset(, 6) = [Agenda!J3] Then
                .Range("A" & y).Offset(1, 0).Resize(, 5) = Sheets("Agenda").Cells(c.Row, 1).Resize(, 5).Value
                y = y + 1
            End If
        Next
    With .Range("B65536").End(xlUp)
        .Offset(1) = "Totaal"
        .Offset(1).Resize(, 4).Font.FontStyle = "Bold"
    End With
    .Range("C65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("C3:C" & .Cells(Rows.Count, 3).End(xlUp).Row))
    .Range("E65536").End(xlUp).Offset(1) = WorksheetFunction.Sum(.Range("E3:E" & .Cells(Rows.Count, 5).End(xlUp).Row))
    End With
End Sub

 

[gl3nn1987]

thanks a lot