automatisch gegevens naar andere sheet

[bowlingman]

Hallo,
In bijlage mijn bestand voor verzamelde munten.
Ik heb hier een module achter geplaatst die ik had gevonden op internet, om bepaalde rijen automatisch naar andere sheets te kopiëren die ook automatisch worden aangemaakt.
De bedoeling is om telkens de gegevens per jaartal naar een betreffende sheet automatisch te kopiëren volgens het jaartal in kolom A.
Ik krijg echter de code van de module niet aangepast om dit te verwezenlijken.
Iemand die een handje kan helpen aub

Grtjs.
Bowlingman

 

[mvdvlist]

Bij mij werkt het feilloos. Misschien heb jij een Engelse versie van Excel?

 

[bowlingman]

Hallo mvdvlist,
Werken doet die module wel, maar er worden sheets gemaakt aan de hand van de gegevens uit kolom D en ik probeer die aan te passen, zodat er sheets worden gemaakt aan de hand van de gegevens in kolom A (de jaartallen) en telkens de gegevens van de rijen van dat jaartal in die sheets worden gekopieerd.

Grtjs.
Armand

 

[mvdvlist]

Was een leesfout. Je wilt het jaartal als bladnaam.

Hier kom ik ook 1.2.3. niet uit, maar waarom zo moeilijk? Veel tabbladen maakt het er niet makkelijker op.

In het voorbeeld heb ik van je gegevens een tabel gemaakt, en op het tabblad Voorblad een aantal slicers. Hier kun je ook makkelijk mee filteren .

 

[JEC.]

Je code aangepast en het werkt

Sub Create_Sheets()
    Application.ScreenUpdating = False
    If Sheets.Count > 1 Then
        Application.DisplayAlerts = False
        For i = Sheets.Count To 2 Step -1
            Sheets(i).Delete
        Next
        Application.DisplayAlerts = True
    End If
    sn = Sheets(1).Cells(1).CurrentRegion.Value
    Set dic = CreateObject("scripting.dictionary")
    For i = 4 To UBound(sn)
        If sn(i, 1) <> vbNullString Then x0 = dic.Item(sn(i, 1))
    Next
    For j = 0 To dic.Count - 1
        Sheets.Add , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = (dic.keys()(j))
        With Sheets(1).Cells(1).CurrentRegion
           .AutoFilter 1, dic.keys()(j)
           .Offset(1).Copy ActiveSheet.Range("A1")
        End With
        With ActiveSheet
            With .Cells(1).CurrentRegion
                .EntireColumn.AutoFit
                .EntireRow.AutoFit
            End With
        End With
    Next
    With Sheets(1)
        .ShowAllData
        .AutoFilterMode = False
        Application.Goto .Range("A1")
    End With
    Application.ScreenUpdating = True
End Sub

 

[HSV]

Hele traject niet gevolgd, maar wat me opviel.

Dit,.....

Sheets.Add , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = (dic.keys()(j))

....kan vast ook zo.

Sheets.Add(, Sheets(Sheets.Count)).Name = dic.keys()(j)

 

[VenA]

Mijn voorkeur gaat uit naar de opzet in #4

Met het geavanceerde filter gaat het denk ik allemaal wat eenvoudiger.

Sub VenA()
  Application.ScreenUpdating = False
  With Sheets("Herdenkingsmunten alle jaren").Cells(1).CurrentRegion
    .Columns(1).AdvancedFilter xlFilterCopy, , .Cells(1, 26), True
    .Cells(1, 26).CurrentRegion.Sort .Cells(1, 26), , , , , , , xlYes
    ar = .Cells(1, 26).CurrentRegion
    .Cells(1, 26).CurrentRegion.Offset(1).Clear
    For j = 2 To UBound(ar)
      If IsError(Evaluate("'" & ar(j, 1) & "'!A1")) Then Sheets.Add(, Sheets(Sheets.Count)).Name = ar(j, 1)
      Sheets(CStr(ar(j, 1))).Cells.Clear
      .Cells(2, 26) = ar(j, 1)
      .AdvancedFilter xlFilterCopy, .Cells(1, 26).CurrentRegion, Sheets(CStr(ar(j, 1))).Cells(1)
      Sheets(CStr(ar(j, 1))).Columns.AutoFit
    Next j
    .Cells(1, 26).CurrentRegion.Clear
    Application.Goto .Cells(1)
  End With
End Sub

NB. Wel unieke kolomkoppen gebruiken.

 

[bowlingman]

Hallo Superhelpers,
Alle drie oplossingen werken goed.
Alleen de oplossing van VenA neemt ook de rij met koppen mee.
Enkel nog een vraagje.
Hoe kan ik de code van VenA aanpassen dat de kolommen J t/m O ook worden geplaats op de jaarsheets (nu gebeurt dat enkel maar tot kolom I). Heb verschillende wijzigingen geprobeerd en krijg het niet voor mekaar.

Grtjs.
Armand

 

[VenA]

Door de lege kolommen J en N weg te halen. Of door iets in J1 en N1 te zetten of de code aanpassen

[COLOR="#FF0000"].resize(,15)[/COLOR].AdvancedFilter xlFilterCopy, .Cells(1, 26).CurrentRegion, Sheets(CStr(ar(j, 1))).Cells(1)

 

[bowlingman]

Bedankt iedereen voor de hulp.
Weeral iets dat ik heb bijgeleerd en kan meenemen naar een volgend projectje.
Wat moet je anders doen in deze kl****te tijden hé.

Grtjs. en Be Save
Armand

 

[VenA]

Wat moet je anders doen in deze kl****te tijden hé.

Een goed boek over VBA bestellen en deze van A tot Z doornemen.:d