gegevens verzamelen van meerdere werkbladen op totaal overzicht

[sb17]

Hallo,

Ik zou graag gegevens van de maandwerkbladen verzamelen op een totaal overzicht werkblad ("Totaal Overzicht"), maar dan alleen van de werkbladen met de naam : jan,feb,mrt,apr enz. Er zijn ook werkbladen zoals " jaaroverzicht ", "begroting" ed. welke niet moeten worden verzameld. Bijgaande code werkt niet geheel goed, de werkbladen staan hier niet in aangegeven. Het bereik is van B9 t/m K9 en dan naar beneden alle gevulde cellen verzamelen van genoemde werkbladen.

de code die ik heb is:

Sub MakeTotalOverView()
    Application.ScreenUpdating = False
    Sheets("Totaal Overzicht").[A2:M65536].ClearContents
    For x = 2 To Sheets.Count
        Sheets(x).Select
        LastRowDest = Sheets("Totaal Overzicht").[A65536].End(xlUp).Row + 1
        LastRowCopy = Sheets(x).[A65536].End(xlUp).Row
        Sheets(x).Range([A2], Cells(LastRowCopy, 13)).Copy
        Sheets("Totaal Overzicht").Cells(LastRowDest, 1).PasteSpecial
    Next x
    Application.Goto Sheets("Totaal Overzicht").[A1]
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Weet iemand hoe ik dit moet aanpassen?

Siebe

 

[VenA]

Probeer het eens op deze manier.

For Each sh In ThisWorkbook.Sheets
 If Len(sh.Name) = 3 Then
    jouw code
Next sh

 

[sb17]

V en A,

Heb jouw advies wellicht iets te letterlijk genomen, maar kom er niet helemaal uit, krijg foutmelding "next zonder For"

Heb nu staan:

Sub MakeTotalOverView()

For Each Sh In ThisWorkbook.Sheets
 If Len(Sh.Name) = 3 Then


    Application.ScreenUpdating = False
    Sheets("Totaal Overzicht").[A2:M65536].ClearContents
    
    For x = 2 To Sheets.Count
        Sheets(x).Select
        LastRowDest = Sheets("Totaal Overzicht").[A65536].End(xlUp).Row + 1
        LastRowCopy = Sheets(x).[A65536].End(xlUp).Row
        Sheets(x).Range([B9], Cells(LastRowCopy, 10)).Copy
        Sheets("Totaal Overzicht").Cells(LastRowDest, 1).PasteSpecial
    Next x
Next Sh
    Application.Goto Sheets("Totaal Overzicht").[A1]
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With

End Sub

Zie je waar het fout gaat?


Siebe

 

[VenA]

Is inderdaad een beetje te letterlijk. Het is mij ook niet helemaal duidelijk of je de gegevens wil kopiëren (is met opmaak en andere toestanden) of alleen de waarden wil ophalen. Voor mij werkt het altijd beter als er een voorbeeldbestandje bijgevoegd is. Dan kan ik mijn mogelijke onzin even testen.

Sub MakeTotalOverView()
Application.ScreenUpdating = False
    Sheets("Totaal Overzicht").[A2:M65536].ClearContents
    For Each sh In ThisWorkbook.Sheets
        With sh
            If Len(.Name) = 3 Then
                LastRowDest = Sheets("Totaal Overzicht").[A65536].End(xlUp).Row + 1
                LastRowCopy = .[A65536].End(xlUp).Row
                .Range([B9], .Cells(LastRowCopy, 10)).Copy
                Sheets("Totaal Overzicht").Cells(LastRowDest, 1).PasteSpecial
            End If
        End With
    Next sh
    With Application
        .Goto Sheets("Totaal Overzicht").[A1]
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Zou het kunnen doen.

 

[Leotaxi]

Hoi Siebe,

test deze eens

Sub MakeTotalOverView()

Application.ScreenUpdating = False
Sheets("TotaalOverzicht").[A2:M65536].ClearContents

For Each sh In ThisWorkbook.Sheets
    If Len(sh.Name) = 3 Then
          lastrow = Sheets(sh.Name).Range("b" & Rows.Count).End(xlUp).Row
          Sheets(sh.Name).Range("b9", "k" & lastrow).Copy Destination:= _
          Sheets("Totaaloverzicht").Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
 Next sh
    
Application.Goto Sheets("TotaalOverzicht").[A1]
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

mvg
Leo


Oeps Immo te laat

 

[VenA]

Oeps Immo te laat

We kunnen natuurlijk nog zoek de tien verschillen doen:d

 

[sb17]

Op zich lukt het aardig zo, dank hiervoor.
Graag nog zou ik de waarden gehaald uit kolom B als datum geplakt willen hebben vanwege groeperen. Kan dit in de code geregeld worden?

Siebe

 

[VenA]

Plaats even een voorbeeldje.

 

[sb17]

Ben even bezig geweest met voorbeeldje, zie bijlage.
Echter in dit bestand willen de data wel groeperen en in mijn oorspronkelijk bestand niet. Het oorspr bestand wordt gevuld met data die eerder uit een bank bestand komt als csv bestand en in kolommen is geplaatst.
wie weet hoedit kan? Ook als de data in tabblad Totaal overzicht via celeigenschappen op datum of aangepast wordt gezet wil het nog niet.

Voor de duidelijkheid, in de bijlage wil dit wel omdat de data daar in de maand werkbladen handmatig zijn ingetypt, maar bij veel trans akties per maand kan dat niet.


Vandaar mijn vraag om de datum kolom in Totaal Overzicht te vullen m.b.v. een stukje code dat wellicht invloed heeft op het groeperen in de draaitabel.

Siebe

 

[VenA]

Plaats even een voorbeeldje zonder externe koppelingen!

 

[sb17]

Bekijk bijlage proefdraaitabel2.xlsm

Deze beter hoop ik.

 

[VenA]

Waarom plaats je dan de 'foute' gegevens niet. Is een beetje moeilijk zoeken waarom iets fout gaat zo. En je tweede bestandje bevat nog steeds koppelingen naar andere bestanden. En dan werkt de copy methode niet.

 

[sb17]

Mijn bedoeling was om het foute bestand dat veel te groot is om te posten af te pellen zodat de foute datums erin blijven en je zo kunt zien waar het mis gaat. Als ik het bestand namaak willen de datums wel groeperen, dus is er ws iets mis met de datum velden. Dat was de reden.
Maar ook als ik dus via celeigenschappen de datum cellen aanpas, wil het groeperen nog niet.
Heb je wellicht nog een idee hoe ik de foute gegevens in een 'schoon' bestandje krijg?

 

[VenA]

Misschien wel maar dan heb ik toch echt de foute gegevens nodig. Maak even een kopie van een csv bestand open deze met bv Notepad. Haal de meeste regels eruit een laat een paar goede en foute regels staan. Als er eventueel gevoelig informatie instaat dan moet je dat even aanpassen. Als de structuur maar hetzelfde blijft. Van de datumvelden moet je natuurlijk afblijven. En plaats dat bestandje eens.

Soms werkt het beter om de extensie van een .CSV aan te passen in bv .TXT en het bestand dan via excel te openen. Je hebt dan iets meer controle over de data in de verschillende kolommen en hoe je het in excel wil hebben.

 

[sb17]

Beste V en A en Leo,

@ VenA, denk dat ik weet wat er fout gaat, in het blad totaal overzicht waaruit de draaitabel gevuld wordt komen de gegevens van de maandtabbladen met 3 letters. Echter de maanden die nog leeg zijn zouden geen gegevens moeten geven. Maar van de lege maanden komen de kolomkoppen ( cel b8 t/m k8 ) onderaan totaaloverzicht te staan. Omdat voor de draaitabelgegevens de gehele kolommen A t/m J gebruikt worden geven de tekstrijen onderaan de tabel dus de fout.

Gebruikte de code van Leo, maar is die aan te passen zodat er bij MakeTotalOvervieuw geen kolomkoppen( van de lege maanden) meer komen te staan?

PS de datumvelden op zich waren dus wel in orde

Siebe

 

[VenA]

Je moet je dan even afvragen waar de eerste gegevens zich bevinden. In het voorbeeldje in rij 9.

Sub MakeTotalOverView()
With Application
    .ScreenUpdating = False
    Sheets("Totaal Overzicht").UsedRange.Offset(1).ClearContents

    For Each sh In ThisWorkbook.Sheets
        If Len(sh.Name) = 3 Then
            lastrow = sh.Range("b" & Rows.Count).End(xlUp).Row
           [COLOR="#FF0000"] If lastrow > 8 Then[/COLOR]
                sh.Range("b9", "k" & lastrow).Copy Destination:= _
                Sheets("Totaal Overzicht").Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
            End If
        End If
    Next sh
    .Goto Sheets("Totaal Overzicht").[A1]
    .CutCopyMode = False
    .ScreenUpdating = True
End With
End Sub

Nb. Hoe krijg je de gele tekstvakken erin en beter nog hoe haal je ze weer uit?

 

[sb17]

VenA,

Om zeker te zijn dat alle datumcellen gelijk zijn wou ik eigenlijk toch met het maken van de TotalOverview kolom A even doorlopen en alle gevulde cellen controleren, hiervoor had ik de volgende code in gedachten, hij duurt nog wat te lang en mist sommige cellen, weet jij hoe dit kan?

Sub MakeTotalOverView()
        With Application
            .ScreenUpdating = False
            Sheets("Totaal Overzicht").UsedRange.Offset(1).ClearContents
        
            For Each sh In ThisWorkbook.Sheets
                If Len(sh.Name) = 3 Then
                    lastrow = sh.Range("b" & Rows.Count).End(xlUp).Row
                    If lastrow > 8 Then
                        sh.Range("b9", "k" & lastrow).Copy Destination:= _
                        Sheets("Totaal Overzicht").Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
                    End If
                End If
            Next sh
            .Goto Sheets("Totaal Overzicht").[A1]
            .CutCopyMode = False
            
        End With
    With Sheets("Totaal Overzicht")
    
        Dim c As Range
        For Each c In Range("A2:A" & Range("A65000").End(xlUp).Row)
        c = Format(c, "dd-mm-yyyy")
        Next
    End With
   ScreenUpdating = True
End Sub

 

[Leotaxi]

Siebe,

vervang deze

        Dim c As Range
        For Each c In Range("A2:A" & Range("A65000").End(xlUp).Row)
        c = Format(c, "dd-mm-yyyy")
        Next

door

 Sheets("totaaloverzicht").Range("a:a").NumberFormat = "dd-mm-yyyy"

mvg
Leo

 

[VenA]

Volgens mij is het voldoende om eenmalig de celeigenschappen goed te zetten. Als er in jouw losse tabjes geen datums staan zal veranderen van het format via code geen invloed hebben.

Nb. Hoe krijg je de gele tekstvakken erin en beter nog hoe haal je ze weer uit?

had je ook even op kunnen reageren. Kan ik zelf natuurlijk wel even uitvogelen. Maar jij gebruikt ze al en dan hoef ik niet te zoeken:d

 

[sb17]

Meende dat ik ergens alwat had gezegd hierover maar vind het niet terug, excuus.
Heb ik gedaan via celeigenschappen opvulling.