Data splitsen in kwartalen

RMSpan · 17 sep 2022

Beste leden
Ik heb een sheet (zie voorbeeld) met data van inkomsten en uitgaven door het jaar heen, wat ik graag wil is deze gegevens in een aparte bestanden kunnen opslaan maar dan per kwartaal.
Dus als het eerste kwartaal geweest is, ik ben nu gegevens bv aan het invullen in april, wil ik een kopie maken van het eerste kwartaal in een nieuw workbook voor de boekhouder.
Is kwartaal 2 geweest en ben ik bv in kwartaal 3 bezig wil ik een kopie maken van alleen de data van kwartaal 2 om weer door te sturen naar de boekhouder, enz.
Aan het eind van het jaar maak ik een kopie van alle gegevens over het hele jaar in een nieuw workbook(dit heb ik werkend, heb ik niet in dit testbestand, zie code) De boekhouder krijgt nu een bestand met alle uitgaven en inkomsten over het hele jaar in één bestand

Code:

Sub Copy_Save_inkomsten_uitgaven()
'Copy_and Save inkomsten/Uitgaven For accountant
 
On Error GoTo ErrorHandler
 
    Dim strWBName As String
    strWBName = ActiveWorkbook.Name
    Dim strWBName2 As String
    strWBName2 = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
    'Year date min one
    Dim YrNr
    YrNr = Year(Date) – 1
 
    'Copy date active workbook sheet inkomsten
    Application.Goto ActiveWorkbook.Sheets("Inkomsten").Range("F6")
    Range("F5:T300").Select
    Selection.Copy
    
    'Past it into workbook Boekhouder.xlsx sheet Inkomsten
     Application.Goto Workbooks.Open("/Users/homecare/Documents/Geertje/Administratie/Accountant/Boekhouder.xlsx").Sheets("Inkomsten").Range("A2")
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    Range("H1") = YrNr
    
    'Go back to former active workbook sheet Uitgaven and copy data and past it into workbook Boekhouder sheet Uitgaven
    Application.Goto Workbooks(strWBName).Sheets("Uitgaven").Range("F6")
    Range("F5:T300").Select
    Selection.Copy
    
    Application.Goto Workbooks("Boekhouder.xlsx").Sheets("Uitgaven").Range("A2")
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    Range("H1") = YrNr
         
    ActiveWorkbook.SaveAs FileName:="/Users/homecare/Documents/Geertje/Administratie/Accountant/" & Range("E1").Value & " " & YrNr & ".xlsx"
    MsgBox ("Bestand opgeslagen onder de naam: /Users/homecare/Documents/Geertje/Administratie/Accountant/") & " " & Range("E1").Value & " " & YrNr & ".xlsx"
    
    'Close workbook Boekhouder and go to former active workbook sheet Dashboard
    ActiveWorkbook.Close
    Application.Goto Workbooks(strWBName).Sheets("Dashboard").Range("A1")
 
    Exit Sub
ErrorHandler:
 
    MsgBox ("Bestand met de naam: /Users/homecare/Documents/Geertje/Administratie/Accountant/") & " " & Range("E1").Value & " " & YrNr & ".xlsx" & " " & "niet vervangen"
    
    'Close workbook Boekhouder, do not save and go to former active workbook sheet Dashboard
    ActiveWorkbook.Close Savechanges = False
    
    Application.Goto Workbooks(strWBName).Sheets("Dashboard").Range("A1")
End Sub

Ik heb geen idee hoe ik de kwartalen apart kan filteren en kopiëren naar een nieuw workbook en of dit überhaupt kan.
De gegevens zijn natuurlijk variabel, bv in kwrt 1 heb ik 10 rijen met uitgaven en 4 rijen met inkomsten en in kwrt 2 heb ik bv 25 rijen met uitgaven en 12 rijen met inkomsten, enz.
Ben benieuwd naar jullie suggesties.

popipipo · 17 sep 2022

Code:

=ROUNDUP((MONTH(B3))/3;0)

Met deze formule kun je het kwartaal bepalen.

Voor de rest zou ik slechts 1 bestand maken en daaruit via een filter het kwartaal bepalen wat je naar boekhouder stuurt.
Dit ipv 4 bestanden maken en daaruit weer 1 bestand maken.

snb · 17 sep 2022

Bij voorkeur:

1 werkblad
1 dynamische tabel
xlsb filetype

popipipo · 17 sep 2022

@snb
Formule voor bepalen kwartaal klopt niet, 1 maart valt toch in het eerste kwartaal.

RMSpan · 17 sep 2022

Bedankt heren voor de info, maar ik zoek meer iets in een VBA code die uit de data de kwartaalgegevens moet halen
Bijvoorbeeld middels een knop die dan kwartaal 1,2,3 of 4 kopieert en in een nieuw Workbook plaatst

RMSpan · 17 sep 2022

popipipo zei:
Code:

=ROUNDUP((MONTH(B3))/3;0)

Met deze formule kun je het kwartaal bepalen.

Deze formule geeft bij mij een foutmelding
Ik heb hem als volgt veranderd:

Code:

=AFRONDEN(MAAND(A3)/3;0)+1

Zonder +1 klopt de uitkomst niet
en met +1 ook niet :d

popipipo · 17 sep 2022

Code:

=AFRONDEN.NAAR.BOVEN((MAAND(B3))/3;0)

volgens mij is dit de juiste vertaling

JEC. · 17 sep 2022

Al sta ik niet achter je aanpak, hier toch een methode. Je moet alleen je pad even aanpassen achter de SaveAs. Dat lukt je wel denk ik.

Code:

Sub jec()
 Dim xp, sh
 xp = Application.InputBox("Welk kwartaal?", , , , , , , 1)
 If xp = False Then Exit Sub
 Application.ScreenUpdating = False
 
 With ThisWorkbook
  .SaveAs .Path & "\" & "testxxqqx.xlsm", 52
   For Each sh In .Sheets
     With sh.Range("A3", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 16)
      .Cells(1, 16).Offset(-1) = "Q"
      .Columns(16).Value = Evaluate("roundup(month(" & .Columns(1).Address & ")/3,0)")
      .Offset(-1).AutoFilter 16, "<>" & xp
      .Offset(1).EntireRow.Delete
      .AutoFilter
     End With
   Next
  .Save
 End With
End Sub

RMSpan · 17 sep 2022

popipipo zei:
Code:

=AFRONDEN.NAAR.BOVEN((MAAND(B3))/3;0)

volgens mij is dit de juiste vertaling

Klopt zo werkt het wel:thumb:

Ik ga even naar de oplossing van JEC kijken

RMSpan · 17 sep 2022

Beste JEC

JEC. zei:

Al sta ik niet achter je aanpak, hier toch een methode. Je moet alleen je pad even aanpassen achter de SaveAs. Dat lukt je wel denk ik.

Code:

Sub jec()
 Dim xp, sh
 xp = Application.InputBox("Welk kwartaal?", , , , , , , 1)
 If xp = False Then Exit Sub
 Application.ScreenUpdating = False
 
 With ThisWorkbook
  .SaveAs .Path & "\" & "testxxqqx.xlsm", 52
   For Each sh In .Sheets
     With sh.Range("A3", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 16)
      .Cells(1, 16).Offset(-1) = "Q"
      .Columns(16).Value = Evaluate("roundup(month(" & .Columns(1).Address & ")/3,0)")
      .Offset(-1).AutoFilter 16, "<>" & xp
      .Offset(1).EntireRow.Delete
      .AutoFilter
     End With
   Next
  .Save
 End With
End Sub

Ik krijg het niet volledig voor elkaar, je code werkt maar op één sheet, van de volgende sheet pakt hij net zoveel rijen maar dan willekeurig.
Deze code heb ik gebruikt:

Code:

Sub jec()
 Dim xp, sh
 xp = Application.InputBox("Welk kwartaal?", , , , , , , 1)
 If xp = False Then Exit Sub
 Application.ScreenUpdating = False
 
 With ActiveWorkbook
   ActiveWorkbook.SaveAs FileName:="/Users/homecare/Documents/Geertje/Administratie/Accountant/" & "test61.xlsm"
   
   For Each sh In .Sheets
     With sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 16)
      .Cells(1, 16).Offset(-1) = "Q"
      .Columns(16).Value = Evaluate("roundup(month(" & .Columns(1).Address & ")/3,0)")
      .Offset(-1).AutoFilter 16, "<>" & xp
      .Offset(1).EntireRow.Delete
      .AutoFilter
     End With
   Next
  .Save
 End With
End Sub

ik heb het basis bestand (map1)en het resultaat bestand(test61) bijgevoegd.
ik hoop dat je er iets mee kan.

snb · 17 sep 2022

Hoe beter de struktuur, hoe eenvoudiger de code.
Het kan eenvoudig met:

Code:

Sub M_snb()
  Application.DisplayAlerts = False
  With Blad1.ListObjects(1).DataBodyRange
    .AutoFilter 3, 2
    .Copy
    With Sheets.Add(, Sheets(Sheets.Count))
      .Paste
      .Copy
      With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\kwartaal2.xlsx", 51
        .Close 0
      End With
      .Delete
    End With
    .AutoFilter
  End With
End Sub

JEC. · 17 sep 2022

Ik zie dat ik een stukje ben vergeten. Morgen zal ik het aanvullen.

RMSpan · 18 sep 2022

snb zei:

Hoe beter de struktuur, hoe eenvoudiger de code.
Het kan eenvoudig met:

Code:

Sub M_snb()
  Application.DisplayAlerts = False
  With Blad1.ListObjects(1).DataBodyRange
    .AutoFilter 3, 2
    .Copy
    With Sheets.Add(, Sheets(Sheets.Count))
      .Paste
      .Copy
      With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\kwartaal2.xlsx", 51
        .Close 0
      End With
      .Delete
    End With
    .AutoFilter
  End With
End Sub

Ik krijg deze niet werkend, krijg de volgende foutmelding, zie afbeelding.

Daarnaast moet ik een extra kolom gaan toevoegen, dat is lastig in het bestaande programma.Bekijk bijlage 366366

RMSpan · 18 sep 2022

JEC. zei:
Ik zie dat ik een stukje ben vergeten. Morgen zal ik het aanvullen.

Ik kijk er naar uit

snb · 18 sep 2022

SVP niet citeren !!!

De afbeelding is voor ons niet zichtbaar.

AD1957 · 18 sep 2022

snb werkt met een echte tabel ListObjects(1), daar zal het in het originele bestand fout gaan.

RMSpan · 18 sep 2022

snb zei:
SVP niet citeren !!!

De afbeelding is voor ons niet zichtbaar.

Sorry, dit tekstbericht krijg ik te zien: " Fout 1004 tijdens runtime. Door toepassing of object gedefinieerde fout

RMSpan · 18 sep 2022

AD1957 zei:
snb werkt met een echte tabel ListObjects(1), daar zal het in het originele bestand fout gaan.

Daar heb ik geen verstand van

JEC. · 18 sep 2022

De evaluate regel iets aangevuld

Code:

Sub jec()
 Dim xp, sh
 xp = Application.InputBox("Welk kwartaal?", , , , , , , 1)
 If xp = False Then Exit Sub
 Application.ScreenUpdating = False
 
 With ThisWorkbook
  .SaveAs .Path & "\" & "testxxqqx.xlsm", 52
   For Each sh In .Sheets
     With sh.Range("A3", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 16)
      .Cells(1, 16).Offset(-1) = "Q"
      .Columns(16).Value = Evaluate("roundup(month('" & sh.Name & "'!" & .Columns(1).Address & ")/3,0)")
      .Offset(-1).AutoFilter 16, "<>" & xp
      .Offset(1).EntireRow.Delete
      .AutoFilter
     End With
   Next
  .Save
 End With
End Sub

AD1957 · 18 sep 2022

In het originele bestand gaat dit dus nooit werken.
https://www.helpmij.nl/forum/showthread.php/965346-error-afhandeling

Data splitsen in kwartalen

Gebruiker

Bijlagen

Meubilair

Verenigingslid

Bijlagen

Meubilair

Gebruiker

Gebruiker

Meubilair

Bijlagen

Terugkerende gebruiker

Gebruiker

Gebruiker

Bijlagen

Verenigingslid

Bijlagen

Terugkerende gebruiker

Gebruiker

Gebruiker

Verenigingslid

Verenigingslid

Gebruiker

Gebruiker

Terugkerende gebruiker

Verenigingslid

Wij waarderen jouw privacy