# Dividing numbers into sheets

The attached excel file containes various number groups. The goal is to divide these groups into various sheets. Using the number in column B the groups would be divided as follows:

The first number is three ( it may be as low as 1 and as high as 50). Thus the script is to take all groups that begin with three and copy and paste them into sheet 2. Then change the name of sheet 2 to the number three.

Next number is four, so all groups containing the number 4 in column B are copied and pasted into the next sheet. (This would be the next sheet following number 3 above.), and the sheet is renamed '4'.

This process continues until all of the rows in the group are accounted for in their own separate sheet.

Keep in mind that other data may be appended to the left or the right of these groups, therefore, the data is not to be manipulated in any other way other than separating them based on the value of column B. Any data around it is to be moved along with the corresponding numbers.

The first two sheets have been manually moved and renumbered in order to explain the process. FYI: The number used can always be expected in column B and the groups should always begin in B3. Also any numbers that do not appear do not get sheets (i.e. 1 and 2 do not have sheets, thus no blank sheets exist)
###### Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

IT Services ConsultantCommented:
The attached excel file...

Divide by zero at line 1.
0
Commented:
^^ In other words, the Excel file is not attached..... ;-)
0
Author Commented:
Seems to give me this problem every so often.
SheetDivisions.xlsx
0
Author Commented:
Ok, I see it now. Hopefully you can also.
0
IT Services ConsultantCommented:
Hi,

The Visual Basic for Applications code below is taken from the Public code module, "basQ_28223794", within the attached workbook.

``````Option Explicit
Public Sub Q_28223794()

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28223794.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               28223794
' Question Title:   Dividing numbers into sheets
' Question Asker:   Pedrov664                                 [ http://www.experts-exchange.com/M_6582434.html ]
' Question Dated:   2013-08-27 at 14:58:45
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
' --------------------------------------------------------------------------------------------------------------

Dim blnApplication_ScreenUpdating                     As Boolean
Dim lngErr_Number                                     As Long
Dim lngLast_Row                                       As Long
Dim lngLoop                                           As Long
Dim lngStart_Row                                      As Long
Dim objCell                                           As Range
Dim objFind                                           As Range
Dim objWorksheet                                      As Worksheet
Dim strErr_Description                                As String
Dim strName()                                         As String

On Error GoTo Err_Q_28223794

ReDim strName(0&) As String

blnApplication_ScreenUpdating = Application.ScreenUpdating

Application.ScreenUpdating = False

For Each objWorksheet In ThisWorkbook.Worksheets

If IsNumeric(objWorksheet.Name) Then
objWorksheet.Delete
End If 'If IsNumeric(objWorksheet.Name) Then

Next objWorksheet

Worksheets("Main Sheet").Activate

lngLast_Row = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1&

[A:A].ClearContents
[B2] = "Key"

lngLast_Row = ActiveSheet.Cells(lngLast_Row + 1&, "B").End(xlUp).Row

ActiveSheet.Range([B2], Cells(lngLast_Row, "B")).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=[A2], _
Unique:=True

lngStart_Row = 0&

For Each objCell In Worksheets("Main Sheet").Range([A3], [A3].End(xlDown))
ReDim Preserve strName(UBound(strName) + 1&) As String
strName(UBound(strName)) = objCell.Value
Next objCell

[B2].ClearContents
[A:A].ClearContents

For lngLoop = 1& To UBound(strName)

If Not (objFind Is Nothing) Then
lngStart_Row = objFind.Row
End If ' If Not (objFind Is Nothing) Then

Set objFind = Worksheets("Main Sheet").Range([B2], Cells(lngLast_Row, "B")).Find(What:=strName(lngLoop), _
LookAt:=xlWhole)

If lngStart_Row > 0& Then
ActiveSheet.Name = strName(lngLoop - 1&)

Worksheets("Main Sheet").Select
Worksheets("Main Sheet").Range(Rows(lngStart_Row), Rows(objFind.Row - 1&)).Copy Destination:=Worksheets(strName(lngLoop - 1&)).Rows(3&)
End If ' If lngStart_Row > 0& Then

Next lngLoop

If lngStart_Row > 0& Then
ActiveSheet.Name = strName(UBound(strName))

Worksheets("Main Sheet").Select
Worksheets("Main Sheet").Range(Rows(objFind.Row), Rows(lngLast_Row)).Copy Destination:=Worksheets(strName(UBound(strName))).Rows(3&)
End If ' If lngStart_Row > 0& Then

Exit_Q_28223794:

Set objFind = Nothing
Set objCell = Nothing
Set objWorksheet = Nothing

Erase strName()
ReDim strName(0&) As String

Worksheets("Main Sheet").Select

Application.ScreenUpdating = blnApplication_ScreenUpdating

MsgBox "Finished!", _
vbInformation Or vbOKOnly, _
ThisWorkbook.Name

Exit Sub

Err_Q_28223794:

lngErr_Number = Err.Number
strErr_Description = Err.Description

On Error Resume Next

Application.ScreenUpdating = True

MsgBox "Error #" & CStr(lngErr_Number) & _
vbCrLf & vbLf & _
strErr_Description, _
vbExclamation Or vbOKOnly, _
ActiveWorkbook.Name

Resume Exit_Q_28223794

End Sub
``````

Please advise if, after executing this code, whether it meets your requirements, or not.

Thank you.

BFN,

fp.
Q-28223794.xlsm
0
Author Commented:
Something interesting happens.

Good points. It runs in record time, despite my slow computer!

However, if you run the attached file you will note that all of the included fields appear to be copied to their corresponding sheets without the field to the left which is a date field.

The date field is deleted from the original sheet and on some runs replaced with blanks. I need this field to be copied with any adjacent cells to their respective sheets AND the original main Sheet is not to be altered in any way.
SheetDivisions.xlsx
0
IT Services ConsultantCommented:
Firstly,... you're welcome.

The "Apparent discrepancy..." you mentioned is because I am using column [A] as part of the process to split the data in the main worksheet into the subsequently created worksheets.

You made no mention of using column [A] in any comment/workbook provided prior to your last comment so, I presumed, as it now transpires, incorrectly, that your data started in column [ B ].

This aside, I can offer a solution that does not touch your original worksheet but, in advance of this, perhaps you can provide a workbook that demonstrates the actual layout/content of the data you are intending to "divide" so that I can ensure that any proposed solution does not interfere with your existing worksheet.

Thank you.
0
Commented:
Hi, I haven't tested any fanpages code, but I decided to add my interpretation of the problem, and think this should do what you need.  Add this code to a module, and run it.

Regards,

Rob.

``````Sub DivideSheets()
Set objMain = Sheets("Main Sheet")
intCurrentNum = objMain.Cells(3, "B").Value
intStart = 3
For intRow = 4 To objMain.Cells(3, "B").End(xlDown).Row + 1
If objMain.Cells(intRow, "B").Value <> intCurrentNum Then
Set objData = Sheets.Add(, Sheets(Sheets.Count))
objData.Name = intCurrentNum
objMain.Rows(intStart & ":" & intRow - 1).Copy objData.Cells(3, "A")
intCurrentNum = objMain.Cells(intRow, "B").Value
intStart = intRow
End If
Next
End Sub
``````
0
Author Commented:
My last post includes an attachment that should provide what you requested
0
Commented:
@Pedrov664, the code I posted should provide what you need.  It appears to work for me.  Add it to a code module and see what you get.

Rob.
0
Author Commented:
Compile Error:

Variable not defined

That is what I get when I run the script above. It is highlightin the objMain on the second line.
0
Commented:
I'm away from my computer at the moment, but add these lines at the top:
Dim objMain
Dim intCurrentNum
Dim intStart
Dim intRow
Dim objData

That will get rid of that error.

Rob.
0
IT Services ConsultantCommented:
My last post includes an attachment that should provide what you requested

The contents of the last attachment you posted (ID: 39448943) is identical to the first attachment (ID: 39445222).

I did check this before I asked you for the additional clarification.

Did you intend to post a different workbook on the second occasion?
0
Author Commented:
Run-time error '1004':

Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic.

That is what I got when I ran it again. I guess it means that since I ran the script once it found a sheet with a name that it was trying to use already in use. So is there a way to clear the slate and start fresh when the script is run?
0
Commented:
Sure, this code will delete all sheets except "Main Sheet", and start again.

``````Sub DivideSheets()
Dim objMain
Dim intCurrentNum
Dim intStart
Dim intRow
Dim objData
Dim objSheet

For Each objSheet In Sheets
If objSheet.Name <> "Main Sheet" Then
objSheet.Delete
End If
Next

Set objMain = Sheets("Main Sheet")
intCurrentNum = objMain.Cells(3, "B").Value
intStart = 3
For intRow = 4 To objMain.Cells(3, "B").End(xlDown).Row + 1
If objMain.Cells(intRow, "B").Value <> intCurrentNum Then
Set objData = Sheets.Add(, Sheets(Sheets.Count))
objData.Name = intCurrentNum
objMain.Rows(intStart & ":" & intRow - 1).Copy objData.Cells(3, "A")
intCurrentNum = objMain.Cells(intRow, "B").Value
intStart = intRow
End If
Next
End Sub
``````

Regards,

Rob.
0
IT Services ConsultantCommented:
Hi again,

Without seeing the extract layout/content of your data, the attached workbook (& transposed code below) is a revision with the proviso that it has not been tested to my satisfaction.

Please repeat your testing to ensure that this meets your requirements.

If anything, I expect that this approach should be much quicker in execution than Rob's method.

(PS. My code had previously removed all created worksheets containing the "divided" data prior to subsequent execution, so that feature continues within the revision below).

``````Option Explicit
Public Sub Q_28223794()

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28223794.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               28223794
' Question Title:   Dividing numbers into sheets
' Question Asker:   Pedrov664                                 [ http://www.experts-exchange.com/M_6582434.html ]
' Question Dated:   2013-08-27 at 14:58:45
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited                           [ http://NigelLee.info ]
' --------------------------------------------------------------------------------------------------------------

Dim blnApplication_ScreenUpdating                     As Boolean
Dim lngErr_Number                                     As Long
Dim lngLast_Row                                       As Long
Dim lngLoop                                           As Long
Dim lngStart_Row                                      As Long
Dim objCell                                           As Range
Dim objFind                                           As Range
Dim objWorksheet                                      As Worksheet
Dim strErr_Description                                As String
Dim strName()                                         As String

On Error GoTo Err_Q_28223794

ReDim strName(0&) As String

blnApplication_ScreenUpdating = Application.ScreenUpdating

Application.ScreenUpdating = False

For Each objWorksheet In ThisWorkbook.Worksheets

If IsNumeric(objWorksheet.Name) Or _
objWorksheet.Name = "Copied Main Sheet" Then
objWorksheet.Delete
End If 'If IsNumeric(objWorksheet.Name) Then

Next objWorksheet

Worksheets("Main Sheet").Select
Worksheets("Main Sheet").Copy After:=Worksheets("Main Sheet")
ActiveSheet.Name = "Copied Main Sheet"

Worksheets("Copied Main Sheet").Activate

lngLast_Row = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1&

[A:A].ClearContents
[B2] = "Key"

lngLast_Row = ActiveSheet.Cells(lngLast_Row + 1&, "B").End(xlUp).Row

ActiveSheet.Range([B2], Cells(lngLast_Row, "B")).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=[A2], _
Unique:=True

lngStart_Row = 0&

For Each objCell In Worksheets("Copied Main Sheet").Range([A3], [A3].End(xlDown))
ReDim Preserve strName(UBound(strName) + 1&) As String
strName(UBound(strName)) = objCell.Value
Next objCell

Worksheets("Main Sheet").Activate

Worksheets("Copied Main Sheet").Delete

For lngLoop = 1& To UBound(strName)

If Not (objFind Is Nothing) Then
lngStart_Row = objFind.Row
End If ' If Not (objFind Is Nothing) Then

Set objFind = Worksheets("Main Sheet").Range([B2], Cells(lngLast_Row, "B")).Find(What:=strName(lngLoop), _
LookAt:=xlWhole)

If lngStart_Row > 0& Then
ActiveSheet.Name = strName(lngLoop - 1&)

Worksheets("Main Sheet").Select
Worksheets("Main Sheet").Range(Rows(lngStart_Row), Rows(objFind.Row - 1&)).Copy Destination:=Worksheets(strName(lngLoop - 1&)).Rows(3&)
End If ' If lngStart_Row > 0& Then

Next lngLoop

If lngStart_Row > 0& Then
ActiveSheet.Name = strName(UBound(strName))

Worksheets("Main Sheet").Select
Worksheets("Main Sheet").Range(Rows(objFind.Row), Rows(lngLast_Row)).Copy Destination:=Worksheets(strName(UBound(strName))).Rows(3&)
End If ' If lngStart_Row > 0& Then

Exit_Q_28223794:

On Error Resume Next

Set objFind = Nothing
Set objCell = Nothing
Set objWorksheet = Nothing

Erase strName()
ReDim strName(0&) As String

Worksheets("Main Sheet").Select

Application.ScreenUpdating = blnApplication_ScreenUpdating

MsgBox "Finished!", _
vbInformation Or vbOKOnly, _
ThisWorkbook.Name

Exit Sub

Err_Q_28223794:

lngErr_Number = Err.Number
strErr_Description = Err.Description

On Error Resume Next

Application.ScreenUpdating = True

MsgBox "Error #" & CStr(lngErr_Number) & _
vbCrLf & vbLf & _
strErr_Description, _
vbExclamation Or vbOKOnly, _
ActiveWorkbook.Name

Resume Exit_Q_28223794

End Sub
``````

Thank you.

BFN,

fp.
Q-28223794b.xlsm
0
Author Commented:
Rob,

Seems your code deletes everything except the one labeled 'main sheet' is there a way to protect more than one sheet from deletion? I ask because this code may be run in a workbook containing more than one sheet that is needed for other tasks.

Fanpages,

Your code has a script labeled 'macro 1' and when I run it it makes a copy of the main sheet. Was this intentional? am I supposed to runs that one first?

Also, when I run your code it appends the current sheet to existing sheets.

Both Fanpages and Rob,

Is there a way for me to protect sheets from deletion or maybe it should prompt me where to begin this way required sheets are not deleted while unneeded with old data are.
0
IT Services ConsultantCommented:
Fanpages,

Your code has a script labeled 'macro 1' and when I run it it makes a copy of the main sheet. Was this intentional? am I supposed to runs that one first?

No, it wasn't intentional.  I just forgot to remove it prior to uploading.  I used this to quickly copy the [Main Sheet] during my local testing.

Here (attached) is an(other) updated workbook.  Please use this instead of any previously posted.

Also, when I run your code it appends the current sheet to existing sheets.

Yes, the revised code's subroutine "Q_28223794" makes a copy of the [Main Sheet], performs filtering on that in situ, stores the filtered list, & then deletes this copy.

This was to ensure that the original worksheet was not altered in any way, as you requested.

Apart from this, does the code address your requirements?
Q-28223794c.xlsm
0
IT Services ConsultantCommented:
Both Fanpages and Rob,

Is there a way for me to protect sheets from deletion or maybe it should prompt me where to begin this way required sheets are not deleted while unneeded with old data are.

You can protect worksheet content from being deleted with worksheet-level password protection (& marking specific cells/ranges as "locked"; "unlocked" cell content is not protected), but not entire worksheets unless you (password) protect the entire workbook (or open it "read only").

Sorry, but I am struggling to comprehend the rest of the paragraph.
0
Author Commented:
Yes, it does address the requirements except for the part that it appends to existing sheets from a previous run and that it may delete sheets that I may need.

The question about protecting sheets is intended to protect sheets from deletion by your script.
0
IT Services ConsultantCommented:
Ah, OK, I understand now.

You are changing the requirements (again)! :)

What would you like to happen on subsequent executions of the same code?

Which worksheets need to be "protected"?

Please define your further requirements fully & then we can look at these.

However, thank you for confirming that I have now met the original requirements.
0
Author Commented:
Fan pages,

I do not believe I am changing the requirements, simply that I should have code that cleans the old worksheets so that I work with the required data and not old data.

I also do not purport to tell you how to write your code. I would have thought that it was understood that this code would be run more than once. In which case the old data needs to be purged so I do not have to sift through old data. Hopefully that clarifies things for you.
0
IT Services ConsultantCommented:
I am not asking you for direction how to code your requirements.

What currently happens is that all worksheets with numeric names are deleted at the start of each subsequent execution.

Rob's suggestion also did something similar; it removed all worksheets not named [Main Sheet].

Yes, I envisaged you executing the code multiple times.  However, there has not been any mention of retaining data until your most recent comments.  I did not know that this was required.

I am asking what are the "rules" for which worksheets remain & which can be removed.

Thank you for relaying your intentions in this regard.
0
Commented:
How about we just have the code delete all sheets named as a integer value? That way, any alpha or alphanumeric sheet name would not be deleted?
In my code, change line 10 to
``````If IsNumeric(objSheet.Name) = True Then
``````

Rob.
0
Author Commented:
Rob,

I am sorry but I do not know where the edited portion goes. Please tell me exactly where or post an updated script attached as a file or posted as code.
0
Commented:
In my code, change this line
``````If objSheet.Name <> "Main Sheet" Then
``````

To this
``````If IsNumeric(objSheet.Name) = True Then
``````

This way it will only delete sheets with a number as their name.

Rob.
0
Author Commented:
Rob,

Ran the code several times with the change denote above and it ran fine until I used a different set of data it gave me

Run-time error '1004':

Application-defined or object error

then it pointed to:

objData.Name = intCurrentNum

I also noted that every time I run the above script with the new data it makes a new sheet named Sheet 133 and then when I run it again the same error and makes a new sheet named Sheet134, etc.
0
Commented:
Ok. Without seeing the new data it's impossible to see what's happening, but I suspect maybe the data isn't sorted before the macro runs? We could force a sort by column B first if you want? Could you post another sample?
0
IT Services ConsultantCommented:
We could force a sort by column B first if you want?

Remembering, of course, the requirement not to change the source worksheet in any way.

Perhaps you could take a copy of the worksheet first, like I did.
0
Commented:
Good point....definately would need to do that....I have now created a copy, sorted it, then divided it, and deleted the copy.

Regards,

Rob.

``````Sub DivideSheets()
Dim objMain
Dim intCurrentNum
Dim intStart
Dim intRow
Dim objData
Dim objSheet

For Each objSheet In Sheets
If IsNumeric(objSheet.Name) = True Then
objSheet.Delete
End If
Next

Sheets("Main Sheet").Copy , Sheets(Sheets.Count)
Set objMain = Sheets(Sheets.Count)
objMain.Name = "Main Sheet - Copy"

objMain.Sort.SortFields.Clear

rngUsedRange = GetUsedRangeAsString(objMain, "sort")

objMain.Sort.SortFields.Add Key:=objMain.Range(rngUsedRange), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With objMain.Sort
.SetRange objMain.Range(rngUsedRange)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

intCurrentNum = objMain.Cells(3, "B").Value
intStart = 3
For intRow = 4 To objMain.Cells(3, "B").End(xlDown).Row + 1
If objMain.Cells(intRow, "B").Value <> intCurrentNum Then
Set objData = Sheets.Add(, Sheets(Sheets.Count))
objData.Name = intCurrentNum
objMain.Rows(intStart & ":" & intRow - 1).Copy objData.Cells(3, "A")
intCurrentNum = objMain.Cells(intRow, "B").Value
intStart = intRow
End If
Next
objMain.Delete
End Sub

Private Function GetUsedRangeAsString(objTheSheet, strRangeType)

' objTheSheet is a sheet object to be passed in
' strRangeType can be either "sort" to return a sortable range, or "used" (default) to return the used range

Dim First_Row As Long, Last_Row As Long
Dim First_Col As Integer, Last_Col As Integer
Dim First_Col_Chr As String, Last_Col_Chr As String

'Check there is at least one non-empty cell
If WorksheetFunction.CountA(objTheSheet.Cells) > 0 Then
'Determine actual used range of worksheet
First_Row = objTheSheet.Cells.Find(What:="*", After:=objTheSheet.Cells(objTheSheet.Rows.Count, objTheSheet.Columns.Count), _
SearchDirection:=xlNext, SearchOrder:=xlByRows).Row
First_Col = objTheSheet.Cells.Find("*", After:=objTheSheet.Cells(objTheSheet.Rows.Count, objTheSheet.Columns.Count), _
SearchDirection:=xlNext, SearchOrder:=xlByColumns).Column
Last_Row = objTheSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Last_Col = objTheSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column

First_Col_Chr = Chr(First_Col + 64)
Last_Col_Chr = Chr(Last_Col + 64)
End If

If LCase(strRangeType) = "sort" Then
GetUsedRangeAsString = First_Col_Chr & First_Row & ":" & First_Col_Chr & Last_Row
Else
GetUsedRangeAsString = First_Col_Chr & First_Row & ":" & Last_Col_Chr & Last_Row
End If

End Function
``````
0
Author Commented:
The attached file has the main sheet data that appears to cause the error. I am sorry about not being able to post earlier.

So the scripts are 'divide sheets' and 'dividesheets_Rob2' the latter being the latest one posted here. Both cause the same error with the _Rob2 component copying the main sheet and then adding the sheet 3 that appears in the attached file. Hopefully this can help to debug it so it works as intended.

P.S.  I seem to incur problems with posting files on this site. IE restarts when I click the upload file button which means I have to restart from scratch.
SheetDivisions-DebugVersion1.xlsm
0
IT Services ConsultantCommented:
No disrespect to anybody intended, but is there a reason that we are continuing with an alternate solution (to the first part of the total set of requirements), when it has already been established that my proposal is a) functioning, & b) functioning quickly?
0
Author Commented:
Fanpages,

I respectfully disagree. Neither script works on the debug version above. If it did for you it did not for me. Please tell me what I need to do to get it to work as intended.
0
Commented:
OK, so the data in your new workbook starts at Row 4.  I have made it start at the first row it finds data in, and it assumes there is always at least two rows of data.

I have also made it forcefully delete any sheet with a numeric name, any sheet name starting with "Sheet", and any sheet named "Main Sheet - Copy".  This way, to keep a sheet, name it anything other than a number, and don't start it with "Sheet".

Regards,

Rob.

``````Sub DivideSheets_Rob3()
Dim objMain
Dim intCurrentNum
Dim intStart
Dim intRow
Dim objData
Dim objSheet

For Each objSheet In Sheets
If IsNumeric(objSheet.Name) = True Or Left(objSheet.Name, 5) = "Sheet" Or objSheet.Name = "Main Sheet - Copy" Then
objSheet.Delete
End If
Next

Sheets("Main Sheet").Copy , Sheets(Sheets.Count)
Set objMain = Sheets(Sheets.Count)
objMain.Name = "Main Sheet - Copy"

objMain.Sort.SortFields.Clear

rngUsedRange = GetUsedRangeAsString(objMain, "sort")

objMain.Sort.SortFields.Add Key:=objMain.Range(rngUsedRange), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With objMain.Sort
.SetRange objMain.Range(rngUsedRange)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

intStart = objMain.Cells(1, "B").End(xlDown).Row
intCurrentNum = objMain.Cells(intStart, "B").Value
For intRow = intStart + 1 To objMain.Cells(intStart, "B").End(xlDown).Row + 1
If objMain.Cells(intRow, "B").Value <> intCurrentNum Then
Set objData = Sheets.Add(, Sheets(Sheets.Count))
objData.Name = intCurrentNum
objMain.Rows(intStart & ":" & intRow - 1).Copy objData.Cells(3, "A")
intCurrentNum = objMain.Cells(intRow, "B").Value
intStart = intRow
End If
Next
objMain.Delete
End Sub
``````
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Author Commented:
You got it! Thank you for all your hard work.
0
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.