Monday, September 19, 2011

Split a workbook into multiple workbooks based on sheet name.

1). Copy below code in fresh workbook module
2). Change the workbook path in code, i have used Book1.xlsx which is there on desktop. hence it's Environ("USERPROFILE") & "\Desktop\Book1.xlsx"
3). Run the code, it will prompt you for no. of copies you want
4). it will automatically save the newly created workbooks in the same location as your original workbook is.
------------------------------------------------ ----------------------------
Sub splitWorkbook()
Dim wkb As Workbook, wks As Worksheet
Dim wksCount As Integer, noOfWkb As Integer, noOfWksInWkb As Integer, wkbCounter As Integer
Dim sheetArr(), tempArr(), wksNameStr As String

'assuming that my workbook is on desktop with Book1.xls as name
'change this path as per your workbook location
Set wkb = Workbooks.Open(Environ("USERPROFILE") & "\Desktop\Book1.xlsx")
wkb.Application.Visible = False

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim i As Integer, j As Integer
wksCount = wkb.Worksheets.Count
noOfWkb = InputBox("How many workbook do you want?", "NKC", 1)
If noOfWkb > wksCount Then Exit Sub

noOfWksInWkb = Int(wksCount / noOfWkb)
ReDim sheetArr(wksCount - 1)
i = 0

For Each wks In wkb.Worksheets
sheetArr(i) = wks.Name
i = i + 1
Next


ReDim tempArr(noOfWksInWkb)

For i = 0 To UBound(sheetArr)
If wksCount - i > noOfWksInWkb Then
For j = 0 To noOfWksInWkb
tempArr(j) = sheetArr(j + i)
Next
wkbCounter = wkbCounter + 1
Else
ReDim tempArr(wksCount - ((noOfWksInWkb + 1) * wkbCounter + 1))

For j = 0 To UBound(tempArr)

tempArr(j) = sheetArr(j + i)
Next

End If

wkb.Sheets(tempArr).Copy
ActiveWorkbook.SaveAs tempArr(LBound(tempArr)) & " to " & tempArr(UBound(tempArr))
ActiveWorkbook.Close False
i = i + noOfWksInWkb
Next

wkb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

No comments:

Post a Comment