Hi...
I have a spreadsheet that has data in columns A-Z, the customer # is in column A, the data is sorted by A and the header data is in row 3. I am in need of an individual spreadsheet being created for each customer containing only their data (A-Z), also containing the header row (Cust #, Cust Name,....) and these new files should be named the customer’s name followed by “Open Orders” and followed by a specified date (date could be answered using a prompt or could pull it from a specific cell in the original spreadsheet (cell B1). All of these new files should be placed in a file on the desktop and the new files should be saved as xls files. All formatting from the original file should be carried over to the individual files.
Ex original data
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0001 AAA 1000 1 3/1/13
0001 AAA 1005 1 3/15/13
0002 BBB 1001 5 2/14/13
0003 CCC 1002 1 2/5/13
0003 CCC 1002 2 3/4/13
A new file named “AAA Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0001 AAA 1000 1 3/1/13
0001 AAA 1005 1 3/15/13
A new file named “BBB Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0002 BBB 1001 5 2/14/13
A new file named “CCC Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0003 CCC 1002 1 2/5/13
0003 CCC 1002 2 3/4/13
I found the code below, which covers alot of what I'm in need of, but.... a major problem is that it doesn’t split the files correctly (data for customer 0003 shows in everyone’s file). With some alteration (that I wish I knew how to do) this macro could be used. Any help with this would be greatly appreciated.
Public Sub SplitToFiles()
' MACRO SplitToFiles
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
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
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
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
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
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 ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
osh.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "\", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")
' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub
I have a spreadsheet that has data in columns A-Z, the customer # is in column A, the data is sorted by A and the header data is in row 3. I am in need of an individual spreadsheet being created for each customer containing only their data (A-Z), also containing the header row (Cust #, Cust Name,....) and these new files should be named the customer’s name followed by “Open Orders” and followed by a specified date (date could be answered using a prompt or could pull it from a specific cell in the original spreadsheet (cell B1). All of these new files should be placed in a file on the desktop and the new files should be saved as xls files. All formatting from the original file should be carried over to the individual files.
Ex original data
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0001 AAA 1000 1 3/1/13
0001 AAA 1005 1 3/15/13
0002 BBB 1001 5 2/14/13
0003 CCC 1002 1 2/5/13
0003 CCC 1002 2 3/4/13
A new file named “AAA Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0001 AAA 1000 1 3/1/13
0001 AAA 1005 1 3/15/13
A new file named “BBB Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0002 BBB 1001 5 2/14/13
A new file named “CCC Open Orders 02/05/2013”
Col A Col B Col C Col D …. Col Z
Cust # Cust Name Order # Line # …. Commit Date
0003 CCC 1002 1 2/5/13
0003 CCC 1002 2 3/4/13
I found the code below, which covers alot of what I'm in need of, but.... a major problem is that it doesn’t split the files correctly (data for customer 0003 shows in everyone’s file). With some alteration (that I wish I knew how to do) this macro could be used. Any help with this would be greatly appreciated.
Public Sub SplitToFiles()
' MACRO SplitToFiles
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
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
'Turn Off Screen Updating Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
' Get cell at cursor
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
' Skip condition met
Else
' Found new section
If iStartRow = 0 Then
' StartRow delimiter not set, meaning beginning a new section
sSectionName = rCell.Text
iStartRow = iRow
Else
' StartRow delimiter set, meaning we reached the end of a section
iStopRow = iRow - 1
' Pass variables to a separate sub to create and save the new worksheet
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Reset section delimiters
iStartRow = 0
iStopRow = 0
' Ready to continue loop
iRow = iRow - 1
End If
End If
' Continue until last row is reached
If iRow < iTotalRows Then
iRow = iRow + 1
Else
' Finished. Save the last section
iStopRow = iRow
CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
iCount = iCount + 1
' Exit
Exit Do
End If
Loop
'Turn On Screen Updating Events
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 ' Copied sheet
Dim awb As Workbook ' New workbook
' Copy book
osh.Copy
Set ash = Application.ActiveSheet
' Delete Rows after section
If iTotalRows > iStopRow Then
DeleteRows ash, iStopRow + 1, iTotalRows
End If
' Delete Rows before section
If iStartRow > iFirstRow Then
DeleteRows ash, iFirstRow, iStartRow - 1
End If
' Select left-topmost cell
ash.Cells(1, 1).Select
' Clean up a few characters to prevent invalid filename
sSectionName = Replace(sSectionName, "/", " ")
sSectionName = Replace(sSectionName, "\", " ")
sSectionName = Replace(sSectionName, ":", " ")
sSectionName = Replace(sSectionName, "=", " ")
sSectionName = Replace(sSectionName, "*", " ")
sSectionName = Replace(sSectionName, ".", " ")
sSectionName = Replace(sSectionName, "?", " ")
' Save in same format as original workbook
ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
' Close
Set awb = ash.Parent
awb.Close SaveChanges:=False
End Sub
