Solved

# Dividing numbers into sheets

Posted on 2013-08-27
Medium Priority
391 Views
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)
0
Question by:Pedrov664
• 14
• 11
• 10

LVL 35

Expert Comment

ID: 39443387
The attached excel file...

Divide by zero at line 1.
0

LVL 65

Expert Comment

ID: 39443941
^^ In other words, the Excel file is not attached..... ;-)
0

Author Comment

ID: 39445222
Seems to give me this problem every so often.
SheetDivisions.xlsx
0

Author Comment

ID: 39445224
Ok, I see it now. Hopefully you can also.
0

LVL 35

Expert Comment

ID: 39447457
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

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
``````

Thank you.

BFN,

fp.
Q-28223794.xlsm
0

Author Comment

ID: 39448943
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

LVL 35

Expert Comment

ID: 39450948
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

LVL 65

Expert Comment

ID: 39450998
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
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 Comment

ID: 39451455
My last post includes an attachment that should provide what you requested
0

LVL 65

Expert Comment

ID: 39451472
@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 Comment

ID: 39452356
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

LVL 65

Expert Comment

ID: 39452885
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

LVL 35

Expert Comment

ID: 39453555
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 Comment

ID: 39454040
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

LVL 65

Expert Comment

ID: 39454413
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
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

LVL 35

Expert Comment

ID: 39454569
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.

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

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 Comment

ID: 39456885
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

LVL 35

Expert Comment

ID: 39456922
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.

Q-28223794c.xlsm
0

LVL 35

Expert Comment

ID: 39456927
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 Comment

ID: 39456936
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

LVL 35

Expert Comment

ID: 39456946
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 Comment

ID: 39456966
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

LVL 35

Expert Comment

ID: 39456978
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

LVL 65

Expert Comment

ID: 39457001
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 Comment

ID: 39458097
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

LVL 65

Expert Comment

ID: 39458200
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 Comment

ID: 39458650
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

LVL 65

Expert Comment

ID: 39458968
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

LVL 35

Expert Comment

ID: 39458997
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

LVL 65

Expert Comment

ID: 39459152
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")

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
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 Comment

ID: 39461359
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

LVL 35

Expert Comment

ID: 39461593
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 Comment

ID: 39461670
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

LVL 65

Accepted Solution

RobSampson earned 2000 total points
ID: 39462472
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")

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
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

Author Closing Comment

ID: 39463622
You got it! Thank you for all your hard work.
0

## Featured Post

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.