Copy cell range onto new tabs sorted in groups

Hi

New to Excel VBA and hoping someone can help.

I am trying to copy a range of cells onto a new tab depending on the 'group value' in column H. The range is sorted in either 3,4,5,6 groups.

The columns and rows on the 'main1' sheet can change and that's where I am struggling. Group 4 needs to appear under Group 1 on the new tab but the rows can differ so potentially causing a overwrite?

I have placed on the 'sorted1' tab exactly how I want the data to appear (in the correct positions ie. cell positions) once the macro runs correctly. File attached.

Can anyone help?

Thanks

Do-able (Excel can do ANYTHING :yes) but it'd be easier if you could accept a single column of Groups


Attachment 23591

Hi Paul

I suppose that would work as it still means I don't have to filter. Had it set the way I did for less scrolling.

I'm slowing realising its power !

Thanks for your help.

Look at this and see if it suits

"Main1" is input to make "Main1-Sorted" as output in the attachment

There are some assumptions made as to the input data structure -- these can be generalized if necessary

Code:

---

Option Explicit


Sub SortIntoGroups()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r1 As Range
    Dim numGroups As Long, numGroup As Long, rowIn As Long, rowOut As Long, rowHeader As Long, rowLast As Long
    Dim numInGroup As Long
   
    'setup and init
    Application.ScreenUpdating = False
   
       
'    Worksheets("Main1").Select      '  for testing
   
   
    Set ws1 = ActiveSheet
   
    'delete output sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(ws1.Name & "-Sorted").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    'create output sheet after input with -Sorted suffix
    Worksheets.Add(, ws1).Name = ws1.Name & "-Sorted"
    Set ws2 = Worksheets(ws1.Name & "-Sorted")
   
    'set source data
    If Len(ws1.Cells(1, 1).Value) = 0 Then
        Set r1 = ws1.Cells(1, 1).End(xlDown).CurrentRegion
    Else
        Set r1 = ws1.Cells(1, 1).CurrentRegion
    End If
   
    rowHeader = r1.Rows(1).Row
    rowLast = r1.Cells(2, 2).End(xlDown).Row
   
    numGroups = Application.WorksheetFunction.Max(r1.Columns(8))
    rowOut = 1
    For numGroup = 1 To numGroups
       
        numInGroup = 1
       
        'add GROUP x
        ws2.Cells(rowOut, 2).Value = "GROUP " & numGroup
        rowOut = rowOut + 1
       
        'add header for each group
        r1.Rows(1).Copy ws2.Cells(rowOut, 1)
        rowOut = rowOut + 1
       
       
        'loop all input rows numGroup times pulling each group individually
        For rowIn = rowHeader To rowLast
            If r1.Cells(rowIn, 8).Value = numGroup Then
                r1.Rows(rowIn).Copy ws2.Cells(rowOut, 1)
                ws2.Cells(rowOut, 1).Value = numInGroup
                numInGroup = numInGroup + 1
                rowOut = rowOut + 1
            End If
       
        Next rowIn
   
        'insert blank line
        rowOut = rowOut + 1
    Next numGroup
    'cleanup
    Application.ScreenUpdating = True
End Sub

---

Paul,

Just curious, what is the difference between the following two statements?

Set r1 = ws1.Cells(1, 1).End(xlDown).CurrentRegion
and
Set r1 = ws1.Cells(1, 1).CurrentRegion

Thanks Paul- that's pretty much it.

However column H value may differ and wouldn't always be 1,2,3 etc. Would be a string value 'Class 1 11/12' for Group 1 for example. Could that easily be changed?

Tried adding another (paltry) variable for each Class group but it's not liking it. Getting a blank sheet created. Ran a test and getting '0' for SetGrp?

Code:

---

        numInGroup = 1
        SetGrp = "Class" & numInGroup & " 11/12"

---

And

Code:

---

        'loop all input rows numGroup times pulling each group individually
        For rowIn = rowHeader To rowLast
            If r1.Cells(rowIn, 8).Value = SetGrp Then
                r1.Rows(rowIn).Copy ws2.Cells(rowOut, 1)
                ws2.Cells(rowOut, 1).Value = SetGrp
                numInGroup = numInGroup + 1
                rowOut = rowOut + 1
            End If
       
        Next rowIn

---

Quote:

---

Originally Posted by MagPower

Paul,

Just curious, what is the difference between the following two statements?

Set r1 = ws1.Cells(1, 1).End(xlDown).CurrentRegion
and
Set r1 = ws1.Cells(1, 1).CurrentRegion

---

Has to do with where the block of data (.CurrentRegion) starts

If it's A3:Z26 vs. A1:26

Re-did the logic to handle Groups not being simple numbers like in first example

Code:

---

Option Explicit


Sub SortIntoGroups()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim r1 As Range
    Dim numGroup As Long, rowIn As Long, rowOut As Long, rowHeader As Long, rowLast As Long
    Dim numInGroup As Long
    Dim collGroups As Collection
    Dim aryGroups() As Variant
    Dim i As Long, j As Long
    Dim vHold As Variant
   
    Worksheets("Main1").Select      '  for testing
   
    'setup and init
    Application.ScreenUpdating = False
    Set collGroups = New Collection
       
    Set ws1 = ActiveSheet
   
    'delete output sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(ws1.Name & "-Sorted").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    'create output sheet after input with -Sorted suffix
    Worksheets.Add(, ws1).Name = ws1.Name & "-Sorted"
    Set ws2 = Worksheets(ws1.Name & "-Sorted")
   
    'set source data
    If Len(ws1.Cells(1, 1).Value) = 0 Then
        Set r1 = ws1.Cells(1, 1).End(xlDown).CurrentRegion
    Else
        Set r1 = ws1.Cells(1, 1).CurrentRegion
    End If
   
    'worksheet row numbers
    rowHeader = r1.Rows(1).Row
    rowLast = r1.Cells(2, 2).End(xlDown).Row
   
   
    'load collection to get unique list
    On Error Resume Next
    For rowIn = rowHeader To rowLast
        If UCase(ws1.Cells(rowIn, 8).Value) <> "GROUP" Then
            collGroups.Add ws1.Cells(rowIn, 8).Value, CStr(ws1.Cells(rowIn, 8).Value)
        End If
    Next rowIn
    On Error GoTo 0
   
    'make array
    ReDim aryGroups(1 To collGroups.Count)
    For numGroup = LBound(aryGroups) To UBound(aryGroups)
        aryGroups(numGroup) = collGroups.Item(numGroup)
    Next numGroup
   
   
    'sort array
    For i = LBound(aryGroups) To UBound(aryGroups) - 1
        For j = i + 1 To UBound(aryGroups)
            If aryGroups(j) < aryGroups(i) Then
                vHold = aryGroups(i)
                aryGroups(i) = aryGroups(j)
                aryGroups(j) = vHold
            End If
        Next j
    Next i
   
    rowOut = 1
    For numGroup = LBound(aryGroups) To UBound(aryGroups)
       
        numInGroup = 1
       
        'add GROUP x
        ws2.Cells(rowOut, 2).Value = "GROUP " & aryGroups(numGroup)
        rowOut = rowOut + 1
       
        'add header for each group
        ws1.Rows(rowHeader).Copy ws2.Cells(rowOut, 1)
        rowOut = rowOut + 1
       
       
        'loop all input rows numGroup times pulling each group individually
        For rowIn = rowHeader + 1 To rowLast
            If ws1.Cells(rowIn, 8).Value = aryGroups(numGroup) Then
                ws1.Rows(rowIn).Copy ws2.Cells(rowOut, 1)
                ws2.Cells(rowOut, 1).Value = numInGroup
                numInGroup = numInGroup + 1
                rowOut = rowOut + 1
            End If
       
        Next rowIn
   
        'insert blank line
        rowOut = rowOut + 1
    Next numGroup
    'cleanup
    Application.ScreenUpdating = True
End Sub

---

That's great Paul - thanks.

Is there a 'True/False' option to overwrite the newly created tab data? If I have a new candidate on the Main1 sheet I may want to re-run the groupings but at the moment it won't allow it.

Thanks again

Quote:

---

Originally Posted by branston

That's great Paul - thanks.

Is there a 'True/False' option to overwrite the newly created tab data? If I have a new candidate on the Main1 sheet I may want to re-run the groupings but at the moment it won't allow it.

Thanks again

---

Not sure I understand. As it was, Main1-Sorted is recreated from scratch each time so a new candidate should be included each time

This version will ask you if you want to replace an existing output sheet if it exists

Code:

---

    'delete output sheet
    On Error Resume Next
    i = -1
    i = Worksheets(ws1.Name & "-Sorted").Index
   
    'output exists if i <> -1
    If i <> -1 Then
        If MsgBox("Output worksheet '" & ws1.Name & "-Sorted' aready exists" & vbCrLf & _
                "Do you want to keep it" & vbCrLf & vbCrLf & _
                "[Yes] = Keep it and exit" & vbCrLf & _
                "[No] = Replace it", vbQuestion + vbYesNo + vbDefaultButton1, "Split Into Groups") = vbYes Then
            Application.ScreenUpdating = True
            Exit Sub
       
        Else
            Application.DisplayAlerts = False
            Worksheets(ws1.Name & "-Sorted").Delete
            Application.DisplayAlerts = True
            On Error GoTo 0
        End If
    End If

---

:yes:yes:yes

You can mark this [Solved] by using Thread Tools above your first post