[CODE]file is uploaded here https://skydrive.live.com/redir?resid=D7C00A2BF29043E0!257
for the spliting part code. i have found the following code from search and it somehow does not work. perhaps needs some
Code:
Sub SplitWorkbook(Optional colLetter As String, Optional SavePath As String)
If colLetter = "" Then colLetter = "P"
Dim lastValue As String
Dim hasHeader As Boolean
Dim wb As Workbook
Dim c As Range
Dim currentRow As Long
hasHeader = True 'Indicate true or false depending on if sheet has header row.
If SavePath = "" Then SavePath = ThisWorkbook.Path
'Sort the workbook.
ThisWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range(colLetter & ":" & colLetter), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ThisWorkbook.Worksheets(1).Sort
.SetRange Cells
If hasHeader Then ' Was a header indicated?
.Header = xlYes
Else
.Header = xlNo
End If
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For Each c In ThisWorkbook.Sheets(1).Range("P:P")
If c.Value = "" Then Exit For
If c.Row = 1 And hasHeader Then
Else
If lastValue <> c.Value Then
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
wb.Close
End If
lastValue = c.Value
currentRow = 1
Set wb = Application.Workbooks.Add
End If
ThisWorkbook.Sheets(1).Rows(c.Row & ":" & c.Row).Copy
wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Select
wb.Sheets(1).Paste
End If
Next
If Not (wb Is Nothing) Then
wb.SaveAs SavePath & "\" & lastValue & ".xlsb"
wb.Close
End If
End Sub
Bookmarks