PDA

View Full Version : [SOLVED] Copy cell range onto new tabs sorted in groups



branston
01-19-2019, 09:25 AM
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

Paul_Hossler
01-19-2019, 10:00 AM
Do-able (Excel can do ANYTHING :yes) but it'd be easier if you could accept a single column of Groups


23591

branston
01-19-2019, 10:37 AM
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.

Paul_Hossler
01-19-2019, 07:57 PM
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




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

MagPower
01-20-2019, 01:05 AM
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

branston
01-20-2019, 03:13 AM
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?



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


And



'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

Paul_Hossler
01-20-2019, 08:54 AM
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

Paul_Hossler
01-20-2019, 09:32 AM
Re-did the logic to handle Groups not being simple numbers like in first example





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

branston
01-20-2019, 10:18 AM
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

Paul_Hossler
01-20-2019, 11:16 AM
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




'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

branston
01-20-2019, 11:32 AM
:yes:yes:yes

Paul_Hossler
01-20-2019, 05:21 PM
You can mark this [Solved] by using Thread Tools above your first post