Gegevens verdelen van 1 sheet over meerdere sheets dmv VBA

[dennio]

Hallo,

In sheet 1 zie je een wat gegevens staan van verschilende afdelingen (30050,30055, en de 30070) (in het echt zijn dit 150 stuks)
Ik wil deze graag verdelen via een macro naar verschillende tabbladen.
Op 1 tabblad moeten dus alle gegevens komen te staan van 1 afdeling.
De gegevens moeten dan komen te staan vanaf cel a4.
Het liefst wil ik nog dat het tabblad naam wordt verandert in het afdelingsnummer (bijv. 30050)

Wie kan mij hiermee helpen?
Alvast bedankt

Bekijk bijlage Testgegevensverdelen.xls

 

[Haije]

waarom via VBA

dennio,

waarom wil je dit via VBA oplossen?

Het is nl heel goed mbv een draaitabel te doen, zie bijlage

 

[gelens]

Dennio,

Er bestaat een add-in voor Excel die dit kan doen.

Zoek eens op Datapigtechnology. Op de site is een stukje freeware te downloaden : Excel Explosion 3.0

 

[dennio]

@Haije Bedankt voor de tip, maar het is niet de bedoeling dat er iets wordt opgeteld of zo.
Alle gegevens die met 1 afdeling te maken heeft, moet of een aparte tabblad komen.
Als dit is gebeurt dan wil ik met een andere macro deze gegevens naar een manager mailen. Vandaar dat ik niets aan een pivot tabble heb.

@Gelens
Ook bedankt voor de tip.
Ik denk niet dat het bedrijf waar ik voor werk zit te wachten of meer software.
Maar ik kan het natuurlijk altijd vragen.

Tot die tijd ga ik nog wel op zoek naar een macro

 

[popipipo]

Hier de splitsing naar verschillende tabbladden.
De vba is niet van mezelf heb hem alleen een beetje aangepast aan jou bestand.

 

[dennio]

Hee popipipo,

De macro werkt geweldig!
Is het mogelijk om ook de * mee te nemen die in het bestand staan?
Dit geeft namelijk aan dat er op die regel en subtotaal staat.
Dit is wat makkelijker lezen voor de ontvanger.
Is het ook mogelijk om de gegevens neer te zetten vanaf cel A4?

Heb wel zelf zitten stoeien, maar het is me helaas niet gelukt.

Groeten

 

[Warme bakkertje]

Private Sub CommandButton1_Click()
    Dim c As Range, ws As Worksheet, ws1 As Worksheet
    Application.ScreenUpdating = False
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    For Each c In ws1.Range("b2", ws1.Range("b" & Rows.Count).End(xlUp))
        If WksExists(c.Text) Then
            Set ws = ThisWorkbook.Worksheets(c.Text)
        Else
            Set ws = ThisWorkbook.Worksheets.Add
            ws.Name = c.Text
        End If
        ws1.Cells(c.Row, 1).Resize(, 42).Copy ws.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)
    Next
ws1.Select
ws1.Columns("aV:aX").Delete
Application.ScreenUpdating = True
End Sub

 

[dennio]

@Warm bakkertje

Ik heb de code gekopieerd maar helaas krijg ik een error;
"complile error, sub or function not defined.
Zie ook bijlagen...
Bekijk bijlage error.doc

 

[Warme bakkertje]

De functie uit het bestand van Popipipo moet er uiteraard ook nog bij gezet worden. Mijn macro was enkel ter vervanging van de huidige macro die je nu hebt.

 

[dennio]

De * worden nu mooi meegenomen. Dit is stukken beter. Dank je wel.
Maar de gegevens worden nog niet neergezet in rij 4.
Wat moet ik hiervoor veranderen?
Tevens zal ik ook graag op iedere pagina een header willen, dus in dit voorbeeld Afdeling - Soort - Bedrag.
De code ziet nu zo uit:

Private Sub CommandButton1_Click()
Dim c As Range
Dim ws As Worksheet
Dim ws1 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Sheet1")

For Each c In ws1.Range("b2", ws1.Range("b" & Rows.Count).End(xlUp))

If WksExists(c.Text) Then

Set ws = ThisWorkbook.Worksheets(c.Text)

Else

Set ws = ThisWorkbook.Worksheets.Add
ws.Name = c.Text

End If

ws1.Cells(c.Row, 1).Resize(, 42).Copy ws.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)


Next

ws1.Select
ws1.Columns("aV:aX").Delete
Application.ScreenUpdating = True
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[dennio]

Hallo,

Heeft iemand enig idee hoe ik dit voor elkaar kan krijgen?
Ik kom er namelijk nog steeds niet uit.

Groeten

 

[Warme bakkertje]

Private Sub CommandButton1_Click()
    Dim c As Range, ws As Worksheet, ws1 As Worksheet
    Application.ScreenUpdating = False
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    For Each c In ws1.Range("b2", ws1.Range("b" & Rows.Count).End(xlUp))
        If WksExists(c.Text) Then
            Set ws = ThisWorkbook.Worksheets(c.Text)
        Else
            Set ws = ThisWorkbook.Worksheets.Add
            ws.Name = c.Text
        End If
        ws.Cells(3, 2).Resize(, 3) = Split("Afdeling|Soort|Bedrag", "|")
        ws1.Cells(c.Row, 1).Resize(, 42).Copy ws.Range("B" & Rows.Count).End(xlUp).Offset(1, -1)
    Next
ws1.Select
ws1.Columns("aV:aX").Delete
Application.ScreenUpdating = True
End Sub

 

[dennio]

@ Warm bakkertje,

Bedankt!! Het werkt perfect :thumb: