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)
Pedrov664Asked:
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.

[ fanpages ]IT Services ConsultantCommented:
The attached excel file...

Divide by zero at line 1.
0
RobSampsonCommented:
^^ In other words, the Excel file is not attached..... ;-)
0
Pedrov664Author Commented:
Seems to give me this problem every so often.
SheetDivisions.xlsx
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Pedrov664Author Commented:
Ok, I see it now. Hopefully you can also.
0
[ fanpages ]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
  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

Open in new window


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

Thank you.

BFN,

fp.
Q-28223794.xlsm
0
Pedrov664Author 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
[ fanpages ]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
RobSampsonCommented:
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

Open in new window

0
Pedrov664Author Commented:
My last post includes an attachment that should provide what you requested
0
RobSampsonCommented:
@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
Pedrov664Author 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
RobSampsonCommented:
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
[ fanpages ]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
Pedrov664Author 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
RobSampsonCommented:
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
            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

Open in new window


Regards,

Rob.
0
[ fanpages ]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
  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

Open in new window


Thank you.

BFN,

fp.
Q-28223794b.xlsm
0
Pedrov664Author 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
[ fanpages ]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
[ fanpages ]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
Pedrov664Author 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
[ fanpages ]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
Pedrov664Author 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
[ fanpages ]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
RobSampsonCommented:
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

Open in new window


Rob.
0
Pedrov664Author 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
RobSampsonCommented:
In my code, change this line
If objSheet.Name <> "Main Sheet" Then

Open in new window


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

Open in new window


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

Rob.
0
Pedrov664Author 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
RobSampsonCommented:
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
[ fanpages ]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
RobSampsonCommented:
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
            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

Open in new window

0
Pedrov664Author 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
[ fanpages ]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
Pedrov664Author 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
RobSampsonCommented:
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
            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
    
    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
    Application.DisplayAlerts = False
    objMain.Delete
    Application.DisplayAlerts = True
End Sub

Open in new window

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.

Start your 7-day free trial
Pedrov664Author 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.