Pedro
asked on
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)
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)
^^ In other words, the Excel file is not attached..... ;-)
ASKER
Seems to give me this problem every so often.
SheetDivisions.xlsx
SheetDivisions.xlsx
ASKER
Ok, I see it now. Hopefully you can also.
Hi,
The Visual Basic for Applications code below is taken from the Public code module, "basQ_28223794", within the attached workbook.
Please advise if, after executing this code, whether it meets your requirements, or not.
Thank you.
BFN,
fp.
Q-28223794.xlsm
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
Application.DisplayAlerts = False
For Each objWorksheet In ThisWorkbook.Worksheets
If IsNumeric(objWorksheet.Name) Then
objWorksheet.Delete
End If 'If IsNumeric(objWorksheet.Name) Then
Next objWorksheet
Application.DisplayAlerts = True
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
Worksheets.Add After:=Worksheets(Worksheets.Count)
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
Worksheets.Add After:=Worksheets(Worksheets.Count)
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.DisplayAlerts = True
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
ASKER
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
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
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.
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.
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.
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
ASKER
My last post includes an attachment that should provide what you requested
@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.
Rob.
ASKER
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.
Variable not defined
That is what I get when I run the script above. It is highlightin the objMain on the second line.
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.
Dim objMain
Dim intCurrentNum
Dim intStart
Dim intRow
Dim objData
That will get rid of that error.
Rob.
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?
ASKER
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?
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?
Sure, this code will delete all sheets except "Main Sheet", and start again.
Regards,
Rob.
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
Application.DisplayAlerts = False
objSheet.Delete
Application.DisplayAlerts = True
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.
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).
Thank you.
BFN,
fp.
Q-28223794b.xlsm
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
Application.DisplayAlerts = 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
Application.DisplayAlerts = True
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
Application.DisplayAlerts = False
Worksheets("Copied Main Sheet").Delete
Application.DisplayAlerts = True
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
Worksheets.Add After:=Worksheets(Worksheets.Count)
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
Worksheets.Add After:=Worksheets(Worksheets.Count)
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.DisplayAlerts = True
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
ASKER
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.
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.
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
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.
ASKER
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.
The question about protecting sheets is intended to protect sheets from deletion by your script.
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.
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.
ASKER
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.
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.
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.
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.
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
Rob.
In my code, change line 10 to
If IsNumeric(objSheet.Name) = True Then
Rob.
ASKER
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.
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.
In my code, change this line
To this
This way it will only delete sheets with a number as their name.
Rob.
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.
ASKER
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.
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.
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?
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.
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.
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
Application.DisplayAlerts = False
objSheet.Delete
Application.DisplayAlerts = True
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)
.Header = xlGuess
.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
Application.DisplayAlerts = False
objMain.Delete
Application.DisplayAlerts = True
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
ASKER
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
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
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?
ASKER
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.
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.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
You got it! Thank you for all your hard work.
Divide by zero at line 1.