• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA for splitting data

sarbashpk

New Member
Please remember to follow all forum rules: Cross-posting
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 doubts.


Code:
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
 
Last edited:
Back
Top