Nieuwe bestanden opslaan op basis van nummer in cel

[halloikke]

Beste,

Ik heb een bestand met daarin een duizendtal variabele nummers. Per nummer kunnen er meerdere regels voorkomen met "subnummers'. Nu wil ik dat er per nummer in Kolom A, een nieuw bestand opgeslagen wordt, met daarbij alle regels waarin dat nummer in Kolom A staat.


als voorbeeld heb ik een geannonimiseerd bestand toegevoegd. Het werkelijke bestand heeft 40.000 regels met ongeveer 1000 hoofdnummers.

In het voorbeeld wil ik dus
Een nieuw bestand met 6 regels voor nummer 1
Een nieuw bestand met 4 regels voor nummer 2
Een nieuw bestand met 10 regels voor nummer 3 etc...


Mike

 

[Gijsbert1]

ongeveer 1000 hoofdnummers

En dus wil je dat er zo'n 1000 bestanden door Excel aangemaakt en opgeslagen gaan worden?????
Waarom?

 

[halloikke]

Omdat ik per nummer (wat een unieke persoon is), een bestand wil hebben dat ik aan de persoon kan toesturen, zonder dat deze informatie van een andere persoon te zien krijgt. Anders moet ik zelf 1000x handmatig de excersitie doen.

 

[Timshel]

Misschien moet je dat versturen ook maar automatiseren. Dat wordt anders ook een handmatige EXERCITIE

Sub tsh()
    Dim Br
    Dim i As Long, vKlant
    Dim Sh, Wb As Workbook
    
    Set Sh = Sheets(1)
    Application.ScreenUpdating = False
    Br = Sh.Cells(1).CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(Br)
            .Item(Br(i, 1)) = 0
        Next
        i = 0
        For Each vKlant In .Keys
            i = i + 1
            Application.StatusBar = "Opslaan #" & i & " van " & .Count
            Sh.Cells(1).CurrentRegion.AutoFilter 1, vKlant
            Set Wb = Workbooks.Add
            Sh.Cells(1).CurrentRegion.Copy Wb.Sheets(1).Cells(1, 1)
            Wb.SaveAs ThisWorkbook.Path & "\" & vKlant & ".xlsx", 51
            Wb.Close False
        Next
    End With
    Sh.Cells(1).CurrentRegion.AutoFilter
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub
b

 

[halloikke]

Beste Timshel,

Bedankt voor de snelle reactie. De macro slaat nu netjes alle nummers op in een eigen bestand. Echter bevatten alle bestanden nog alle data. Zou je het nog zo aan kunnen passen dat per nummer ook alleen de data behorende aan dat nummer getoond worden?

Misschien moet je dat versturen ook maar automatiseren. Dat wordt anders ook een handmatige EXERCITIE

Sub tsh()
    Dim Br
    Dim i As Long, vKlant
    Dim Sh, Wb As Workbook
    
    Set Sh = Sheets(1)
    Application.ScreenUpdating = False
    Br = Sh.Cells(1).CurrentRegion
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(Br)
            .Item(Br(i, 1)) = 0
        Next
        i = 0
        For Each vKlant In .Keys
            i = i + 1
            Application.StatusBar = "Opslaan #" & i & " van " & .Count
            Sh.Cells(1).CurrentRegion.AutoFilter 1, vKlant
            Set Wb = Workbooks.Add
            Sh.Cells(1).CurrentRegion.Copy Wb.Sheets(1).Cells(1, 1)
            Wb.SaveAs ThisWorkbook.Path & "\" & vKlant & ".xlsx", 51
            Wb.Close False
        Next
    End With
    Sh.Cells(1).CurrentRegion.AutoFilter
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub
b

 

[halloikke]

Sorry ik was te snel. De macro werkt perferct, alleen had ik de gegevens als tabel in excel staan. Na deze als gewone data te plakken lukt het perfect. Thanks!