Macro om excel bestanden te splitsen en bovenste regel telkens te behouden

[Pascal1987]

Goedemorgen,

Ik heb lange excel bestanden van 10.000+ die ik graag in kleinere excel bestandjes wil opslaan van ±500 rijen lang. Nu heb ik een macro gevonden die dat doet alleen wil ik graag de bovenste regel van het lange bestand steeds als eerst kopiëren zodat ik op elk los bestand de naam titel enz. enz. telkens boven aan krijg zonder dat ik dat handmatig hoef te doen.

Wie kan mij helpen en mijn macro script aanpassen???

Ik gebruik het volgende script:

Public Sub SplitExcelWorksheet()
Dim lines As Long, lastline As Long, ll As Long
lines = 500
lastline = Cells.SpecialCells(xlCellTypeLastCell).Row
Dim from As Worksheet
Set from = ActiveSheet
For ll = 0 To lastline / lines
Dim a As Workbook
Set a = Workbooks.Add
from.Range(ll * lines + 1 & ":" & (ll + 1) * lines).Copy _
a.Worksheets(1).Range("1:" & lines)
'a.SaveAs "name" & ll ?
a.Close
Next ll
End Sub

Ik hoop dat iemand mij kan helpen want het scheelt mij enorm veel werk als ik dit handmatig zou moeten doen.

Alvast bedankt iedereen!

 

[gast0660]

Hoi,
Welkom op het forum
Waarom stel je 2x dezelfde vraag?(geen geduld??:d)
Plaats de volgende keer je code tussen codetags,maakt de zaak wat beter leesbaar. (het # teken)

Sub dotch()
Dim inputFile As String, inputWb As Workbook
    Dim lastRow As Long, row As Long, n As Long
    Dim newSH As Workbook
With ThisWorkbook.ActiveSheet
    lastRow = .Cells(Rows.Count, "A").End(xlUp).row
    Set newSH = Workbooks.Add
    n = 0
    For row = 2 To lastRow Step 500
        n = n + 1
        .Rows(1).EntireRow.Copy newSH.Worksheets(1).Range("A1")
        .Rows(row & ":" & row + 500 - 1).EntireRow.Copy newSH.Worksheets(1).Range("A2") 
        newSH.SaveAs Filename:=n & ".xlsx"
    Next
End With
newSH.Close saveChanges:=False
End Sub

 

[jkpieterse]

Waarom wil je dit eigenlijk precies?

 

[Pascal1987]

Script werkt niet

Ik heb het geprobeerd maar het script dat je hebt gestuurd werkt helaas niet

 

[Pascal1987]

Als iemand een andere methode weet om op elke lege werkmap automatisch de titel regel in te vullen dan mag dat ook want het script zoals ik hem erop gezet hebt werkt prima alleen ik wil graag de eerste regel telkens behouden.. Wie kan mij helpen?????

 

[gast0660]

werkt helaas niet

Daar weten we natuurlijk niets meer mee.
Graag wat meer uitleg.
Zie voorbeeldje
zelfde script, splits het voorbeeldje om de twee lijnen

 

[Pascal1987]

Public Sub SplitExcelWorksheet()
    Dim lines As Long, lastline As Long, ll As Long
    lines = 500
    lastline = Cells.SpecialCells(xlCellTypeLastCell).Row
    Dim from As Worksheet
    Set from = ActiveSheet
    For ll = 0 To lastline / lines
        Dim a As Workbook
        Set a = Workbooks.Add
        from.Range(ll * lines + 1 & ":" & (ll + 1) * lines).Copy _
            a.Worksheets(1).Range("2:" & lines)
        'a.SaveAs "name" & ll ?
        a.Close
    Next ll
End Sub

Dit werkt perfect heb nu de eerste regel telkens blanco maar ik zou graag geautomatiseerde tekst willen invoegen zoals bij A1 naam B1 adres C1 telefoonnummer enz. enz.

 

[Pascal1987]

Mijn excuses het script werkt super ik deed zelf iets fout! Heel erg bedankt voor je hulp! Echt Super BEDANKT!!!

 

[gast0660]

Mooi zo :thumb:
Suc6