Macro om Excel lijst te splitsen naar meerdere Excel bestanden

[Markkreikamp]

Goedemiddag,

Ik heb een Excel bestand als bulk met 500+ bedrijven, en in deze bulk staat per rij het bedrijf en de werknemer. Er zijn dus in totaal zo'n 20.000 rijen. Nu is het de bedoeling dat ieder bedrijf in een aparte Excel wordt opgeslagen, maar wel met behoud van de werknemers (het aantal werknemers per bedrijf varieert, dus ook het aantal rijen per bedrijf. Er is een uniek nummer aanwezig (Herkenningscode). Hieraan wordt altijd gekoppeld om welk bedrijf het gaat.


Ik heb al geprobeerd om hier een macro voor te ontwikkelen, maar kom niet verder dan alleen een bepaalde range op te slaan.

Kan iemand mij verder helpen?

 

[edmoor]

Vind je het niet handiger om een tabblad per bedrijf te hebben in plaats van losse bestanden?

 

[Markkreikamp]

Ja, is ook een optie!

 

[snb]

Daarvoor heeft MS de 'slimme' tabel uitgevonden.

Zie de bijlage

 

[Markkreikamp]

Hierdoor heb je nog steeds geen tabblad per bedrijf, en om 500+ keer te gaan klikken op een draaitabel, en vervolgens het tabblad een naam te geven van het bedrijf is niet gewenst.
De wens is om het per Excel te krijgen i.v.m. aanlevering bij een externe partij, maar als dit niet mogelijk is dmv een macro of iets dergelijks, voldoet het ook per tabblad.

 

[snb]

Deze tabel is geen draaitabel: kijk maar in je handboek Excel of les 3 van de cursus.

 

[Markkreikamp]

Ik snap dat dit geen draaitabel is, maar een simpele tabel met een filter erop (of zie ik iets over het hoofd). Hiermee krijg ik nog steeds niet in één keer de bulk uitgesplitst per Excel / per tabblad, maar moet ik één voor één het bedrijf af en kopiëren/plakken.

 

[Timshel]

Probeer het eens met deze macro:

Sub tsh()
    Dim Br, Bq, Bs
    Dim i As Long
    
    Br = Sheets("Blad1").Cells(1).CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(Br)
            .Item(Br(i, 1)) = .Item(Br(i, 1)) & "|" & i
        Next
        For Each Bq In .Keys
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = Bq
            Sheets("Blad1").Range("A1:D1").Copy Range("A1")
            Bs = Application.Transpose(Split(Mid(.Item(Bq), 2), "|"))
            Cells(2, 1).Resize(UBound(Bs), 4) = Application.Index(Br, Bs, [column(A:D)])
            Range("A1:D1").EntireColumn.AutoFit
        Next
     End With
End Sub

 

[Markkreikamp]

Bedankt! Bijna helemaal, het originele bestand heeft meer dan 4 kolommen. Maar gezien de macro kom ik er wel uit met vergroten van het bereik qua kolommen (nummer "4" en de columns "A : D" uitbreiden lijkt me voldoende).

 

[snb]

@timshel

Sheets.Add(,Sheets(Sheets.Count)).Name = Bq