Inhoud tabblad wegschrijven naar aparte exceldocumenten

[rista62]

Hallo,

Ik heb een bestand in Excel 2003 waar in één tabblad per lid een report staat. Ik wil voor ieder lidnr. een apart excel document wegschrijven waarin zijn gegevens staan. Dus voor lidnr. 1 is dit dus bereik B2:J6 (zie bijlage).
Ik heb in bijgaand document 4 leden opgenomen, maar in werkelijkheid gaat het om veel meer, waardoor dit niet meer handmatig te doen is. Kan iemand mij op weg helpen met een macro in VBA? Let op mijn kennis van VBA code is zeer beperkt, dus als er uitleg bij kan heel graag.
Alvast dank.
Gr.
R.

 

[paulva]

Je zou dat beter doen met op het eerste tabblad de gegevens en een macro die de lay-out op een ander tabblad maakt zoals jij dat wilt.
Het is me ook niet duidelijk hoe de cellen g6, h6 en i6 berekend worden.
Als je me de bovenstaande info geeft, dan wil ik je wel een begin van een 'databank' maken.

 

[paulva]

Sorry, ik heb (alweer) het probleem verkeerd ingeschat.
Ik denk dat je het bijgevoegde bestandje wil hebben.
Eerst lokaal opslaan en dan pas klikken op de knop. In dezelfde map vind je dan de bestanden met als naam het lidnummer.
Beste groeten,
Paul.
Bekijk bijlage aparteDocumenten.xls

 

[Mark xl]

Het is me ook niet duidelijk hoe de cellen g6, h6 en i6 berekend worden.
.

ik denk
voor "G6" =AANTAL.ALS(G3:G5;"ja")
voor "H6" =AANTAL.ALS(H3:H5;"ja")
voor "I6" =ALS(AANTAL.ALS(I3:I5;"ja")>0;"ja";"nee")

Edit: Ha. je had het stiekem al opgelost!

Edit2: Ik kon het niet laten hier een variant op te bedenken. via een oude truc met findprevious
kan ik zoiets ook in een spoiler / verborgen tags zetten ofzo?

Option Explicit
Public Sub Splits_Blocks()
Dim strFirst As String
Dim strFilename As String
Dim rngStart As Range
Dim rngEnd As Range

    Set rngEnd = Range("I65535").End(xlUp).Offset(, 1)
    Set rngStart = FindPrev(Range("B1"), "lidnr")
    strFirst = rngStart.Address

    Do
        'rngStart.Offset(1, 0) = Lidnr
        'rngStart.Offset(1, 1) = Naam
        strFilename = ThisWorkbook.Path & "\" & _
                     rngStart.Offset(1, 0) & " " & _
                     rngStart.Offset(1, 1) & ".xls"
        SaveRangeAsWorkbook RangeToSave:=Range(rngStart, rngEnd), _
                            FileName:=strFilename
        Set rngEnd = rngStart.Offset(-1, 7)
        Set rngStart = FindPrev(rngStart, "lidnr")

    Loop Until rngStart.Address = strFirst

    Set rngStart = Nothing
    Set rngEnd = Nothing

End Sub

Private Sub SaveRangeAsWorkbook(ByVal RangeToSave As Range, _
                                ByVal FileName As String)
    With Workbooks.Add
        RangeToSave.Copy Destination:=.Sheets(1).Range("a1")
        .SaveAs FileName:=FileName, _
                FileFormat:=xlExcel8
        .Close
    End With
End Sub

Private Function FindPrev(ByVal rngAfter As Range, _
                          ByVal strWhat As String) As Range
    Set FindPrev = _
    Columns(rngAfter.Column).Find(What:=strWhat, _
                                  After:=rngAfter, _
                                  LookIn:=xlValues, _
                                  Lookat:=xlWhole, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False)
End Function