VBA for splitting data

[sarbashpk]

I have a macro code to split the data into multiple workbook . this code we can use in any excel files to split the data .. when we run the macro it will ask the column number and row number and save the final split wise file in split folder . unfortunately there is an issue with the macro in save part ..something wrong with save path.

also in this macro , its splitting only one line item rather than splitting whole data.

Can you please correct the macro and there are few additional requirements also which we need to amend in the macro as below:

1) My excel file contains 2 tabs , summary tab and data tab . i would like to split the data along with the summary tab...so after splitting the file , i need both summary and data tabs in all split wise files.

2)curser should be on top (eg cell A1) in both tabs

3) file should be saved as " filename -split name " eg: i ant to split file "sales report" based on the sales persons..then file name should save as " sales report-person name".

below is the macro..can some one help me to amend the macro based on my requirements. let me know if you have any queries.

Public Sub SplitToFiles()

Dim osh As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim iFirstRow As Long
Dim iTotalRows As Long
Dim iStartRow As Long
Dim iStopRow As Long
Dim sSectionName As String
Dim rCell As Range
Dim owb As Workbook
Dim sFilePath As String
Dim iCount As Integer
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")

    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
    Else

        If iStartRow = 0 Then
    
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            iStopRow = iRow - 1
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1
            iStartRow = 0
            iStopRow = 0
            iRow = iRow - 1
        End If
    End If
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
       
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1
        Exit Do
    End If
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath
End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet
     Dim awb As Workbook
     osh.Copy
     Set ash = Application.ActiveSheet
        If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If
     ash.Cells(1, 1).Select
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")

    
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

    
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

Also posted


VBA for splitting data
VBA for splitting data - OzGrid Free Excel/VBA Help Forum
Vba for splitting data into multiple workbook

 

[Alexy888]

hello
"unfortunately there is an issue with the macro in save part ..something wrong with save path." ==> I think the path name is too long for Excel 5there is a limit in the number of characters).
Try to run the macro from a different folder ex C://

Also, for the several files I think it comes from your data are not sorted in the column you want to split your data from. You'll need to either sort it (A to Z or Z to A no importance) before running the macro or insert in the macro a VBA code that does it based on the column the user has chosen.

regards