Spliting excel data into multiple files based on number of rows with column headings

[smiet]

I don't have much VBA knowledge, so it's been a struggle for me. I have this list of person information with six columns, viz., Serial No., First Name, Last Name, Age, Email and Contact number with around 800+ rows. I want this list to split up into different excel workbooks (.xls) with 30 lines in a file without changing serial no. In the same VBA I want to change column widths so that it would fit into A4 size pages and most important thing is I don't want these file to be saved, that means I want them be opened after macro has finished running.

Can anyone please provide certain light or proper solution on this?

 

[ranman256]

paste into VBE
run: SplitIntoWbs

  'split ws into separate workbooks
'---------------
Sub SplitIntoWbs()
'---------------
Const kMAX = 30
Dim wb As Workbook


Set wb = ActiveWorkbook


Range("A2").Select
While ActiveCell.Value <> ""
    Rows("1:" & kMAX).Select
    
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    PageSetup
    
    wb.Activate
    Rows("2:" & kMAX).Select
    Selection.Delete Shift:=xlUp
    Range("A2").Select
Wend
wb.Close False
Set wb = Nothing
End Sub
'---------------
Private Sub PageSetup()
'---------------
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Application.CutCopyMode = False


    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    Range("A1").Select
End Sub

 

[smiet]

Thanks ranman256, it worked, kudos. But I want to give constant column width for all excels, for example., Serial No. as 10, First Name as 25, Last Name 20, etc.

Can you please reply again?

 

[ranman256]

record a macro
set the col width on one
stop macro.
edit the macro
now you see syntax for the 1, so set all the others.
then just add this macro as the first line in SUB PAGESETUP.
INSTEAD OF THE LINE: AUTOFIT (remove the autofit line)

 

[smiet]

Thanks Ranman256, you've been a great help.