Macro - sorting by a specific word

A

ApolloID

Well-known Member
Joined
Jun 8, 2010
Messages
769
Hi,

I have the below table and i need a macro to sort by specific words in column "D", words that are part of a group, then to add the name of the group in column B. And after each group to make a total for that group's value and qty.
The table starts from A5.

SupplierGroupCodDescriptionValueQty
supplier 1s 228scissor 13,781.191,614.00
supplier 2t 141tweezer 822,187.251,958.00
supplier 2t 222tweezer 1015,515.334,184.00
supplier 1s 259scissor 898,214.133,435.00
supplier 1s 235cuticle scissor 331,989.64775.00
supplier 2t389oblique tweezer 162,989.121,312.00

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

This is how i need the table to be:
SupplierGroupCodDescriptionValueQty
supplier 1scissors 228scissor 13,781.191,614.00
supplier 1scissors 259scissor 898,214.133,435.00
supplier 1scissors 235cuticle scissor 331,989.64775.00
scissor total13,984.965,824.00
supplier 2tweezert 141tweezer 822,187.251,958.00
supplier 2tweezert 222tweezer 1015,515.334,184.00
supplier 2tweezert389oblique tweezer 162,989.121,312.00
tweezer total10,691.707,454.00

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

I need to make groups inside the macro with products that will be part of that group. The words could be at the begining or as part of the product name.
Also, it would be great to put all unidentified products to an "Unknown" group at the end of all sorted groups.

Can this be done?
Thank you in advance,

Apollo.
 

Excel Facts

Whats the difference between CONCAT and CONCATENATE?
The newer CONCAT function can reference a range of cells. =CONCATENATE(A1,A2,A3,A4,A5) becomes =CONCAT(A1:A5)
Sort by date Sort by votes
I would think that to be able to attempt this you would need either ..

a) A defined list of group names (eg "scissor" and "tweezer" for your sample. Otherwise how would we know that "cuticle scissor" belongs to the "scissor" group and not the "cuticle" group or a "cuticle scissor" group?

or

b) A definite rule that all group names are single words and appear as the second last group of characters in column D as that appears the case for your sample. Or a similar rule.
 
Upvote 0
ApolloID,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


On another worksheet with the name GROUPS, beginning in cell A1 (down):
3. create the list of single word, sorted unique groups

Then post the new screenshot.
 
Upvote 0
Hi,

Thank you for your reply.
You are right, confusions can appear due to description multiple words.
I will make a group list in sheet2 and it would look like this starting with A1 (single word group):

SupplierGroupCodDescription
supplier 1scissors 228 scissor 1
supplier 2tweezert 141 tweezer 82

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

I am using Windows7 and excel 2010.
But after your observations, i realise that i need the percentage of each group value/qty from the overall value/qty. And it would be great to have a second macro to filter either by group's value percentage of by group's qty percentage.

SupplierGroupCodDescriptionValue%Qty%
supplier 1scissors 228scissor 13,781.191,614.00
supplier 1scissors 259scissor 898,214.133,435.00
supplier 1scissors 235scissor 331,989.64775.00
scissor total13,984.9657%5,824.0044%
supplier 2tweezert 141tweezer 822,187.251,958.00
supplier 2tweezert 222tweezer 1015,515.334,184.00
supplier 2tweezert389tweezer 162,989.121,312.00
tweezer total10,691.7043%7,454.0056%
Groups Total:24,676.66100%13,278.00100%

<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

Can this be done?
Thank you in advance,
Apollo.
 
Upvote 0
ApolloID,

Sample raw data worksheets:


Excel 2007
ABCD
1SupplierGroupCodDescription
2supplier 1scissors 228scissor 1
3supplier 2tweezert 141tweezer 82
4
Sheet2



Excel 2007
ABCDEFGH
1SupplierGroupCodDescriptionValue%Qty%
2supplier 1s 228scissor 13,781.191,614.00
3supplier 2t 141tweezer 822,187.251,958.00
4supplier 2t 222tweezer 1015,515.334,184.00
5supplier 1s 259scissor 898,214.133,435.00
6supplier 1s 235scissor 331,989.64775
7supplier 2t389tweezer 162,989.121,312.00
8
9
10
11
12
Sheet1


After the macro in worksheet Sheet1:


Excel 2007
ABCDEFGH
1SupplierGroupCodDescriptionValue%Qty%
2supplier 1scissors 228scissor 13,781.191,614.00
3supplier 1scissors 259scissor 898,214.133,435.00
4supplier 1scissors 235scissor 331,989.64775
5scissor total13,984.9657%5,824.0044%
6supplier 2tweezert 141tweezer 822,187.251,958.00
7supplier 2tweezert 222tweezer 1015,515.334,184.00
8supplier 2tweezert389tweezer 162,989.121,312.00
9tweezer total10,691.7043%7,454.0056%
10
11Groups Total:24,676.66100%13,278.00100%
12
Sheet1
Cell Formulas
RangeFormula
E5=SUM(E2:E4)
E9=SUM(E6:E8)
G5=SUM(G2:G4)
G9=SUM(G6:G8)
F11=SUM(F2:F9)
H11=SUM(H2:H9)


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code: 
Sub ReorgData()
' hiker95, 10/23/2014, ME813518
Dim g, i As Long
Dim r As Long, lr As Long
Dim Area As Range, sr As Long, er As Long
Dim etot As Double, gtot As Double
Application.ScreenUpdating = False
With Sheets("Sheet2")
  g = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = 2 To lr
    For i = LBound(g) To UBound(g)
      If InStr(.Cells(r, 4), g(i, 1)) Then
        .Cells(r, 2).Value = g(i, 1)
        Exit For
      End If
    Next i
  Next r
  .Range("A2:H" & lr).Sort key1:=.Range("B2"), order1:=1, key2:=.Range("A2"), order1:=1
  For r = lr To 3 Step -1
    If .Cells(r, 2).Value <> .Cells(r - 1, 2).Value Then .Rows(r).Insert
  Next r
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For Each Area In .Range("A2:A" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      With Cells(er + 1, 2)
        .Value = Cells(er, 2).Value & " total"
        .Font.Bold = True
      End With
      With Cells(er + 1, 5)
        .Value = "=SUM(E" & sr & ":E" & er & ")"
        .Font.Bold = True
        .NumberFormat = "#,##0.00"
      End With
      etot = etot + Cells(er + 1, 5)
      With Cells(er + 1, 7)
        .Value = "=SUM(G" & sr & ":G" & er & ")"
        .Font.Bold = True
        .NumberFormat = "#,##0.00"
      End With
      gtot = gtot + Cells(er + 1, 7)
    End With
  Next Area
  With Cells(er + 3, 2)
    .Value = "Groups Total:"
    .Font.Bold = True
  End With
  With Cells(er + 3, 5)
    .Value = etot
    .NumberFormat = "#,##0.00"
    .Font.Bold = True
  End With
  With Cells(er + 3, 7)
    .Value = gtot
    .NumberFormat = "#,##0.00"
    .Font.Bold = True
  End With
  For Each Area In .Range("A2:A" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      With Cells(er + 1, 6)
        .Value = Cells(er + 1, 5) / etot
        .Font.Bold = True
        .NumberFormat = "0%"
      End With
      With Cells(er + 1, 8)
        .Value = Cells(er + 1, 7) / gtot
        .Font.Bold = True
        .NumberFormat = "0%"
      End With
    End With
  Next Area
  With Cells(er + 3, 6)
    .Value = "=SUM(F2:F" & lr + 1 & ")"
    .NumberFormat = "0%"
    .Font.Bold = True
  End With
  With Cells(er + 3, 8)
    .Value = "=SUM(H2:H" & lr + 1 & ")"
    .NumberFormat = "0%"
    .Font.Bold = True
  End With
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.
 
Upvote 0
I'm a little confused as the multiple word descriptions have disappeared from the sample data so I don't know if they no longer exist or if they do exist we don't have a clear example of what to do with them.
Also, the list in Sheet2, as far as I understand, just needs to be a list of the groups to use. That is, just what you have in column B of Sheet2.

Anyway, I have used the Sheet2 layout you used and if hiker's code produces the results you want, then I think this shorter code should too.
It also provides individual or collective group collapse/expand options in the left hand margin.
My assumption that the original data in columns E & G does not contain formulas. If that assumption is incorrect, some slight adjustments to the code could be implemented.

Rich (BB code): 
Sub Make_Groups()
  Dim lr As Long
  Dim sGroupadr As String
  
  Application.ScreenUpdating = False
  sGroupadr = "'" & Sheets("Sheet2").Name & "'!" & Sheets("Sheet2").Range("A1").CurrentRegion.Columns(2).Address
  With Sheets("Sheet1")
    lr = .Range("A" & .Rows.Count).End(xlUp).Row
    With .Range("B2:B" & lr)
      .Formula = Replace("=LOOKUP(2,1/SEARCH(#,D2),#)", "#", sGroupadr)
      .Value = .Value
    End With
    With .Range("A1").CurrentRegion
      .Sort Key1:=.Cells(2, 2), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5, 7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    End With
    lr = .Range("E" & .Rows.Count).End(xlUp).Row
    With .Columns("E:G").SpecialCells(xlFormulas).Offset(, 1)
      .FormulaR1C1 = "=RC[-1]/R" & lr & "C[-1]"
      .NumberFormat = "0%"
      .EntireRow.Font.Bold = True
    End With
  End With
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hi,

Thank you very much! I'ts working!
I will play with the code and my datas to see if i will encounter any problems and be back with my feedback.

Please tell me, if it's possible to fill the "Total" row with color and also the bold text to have a color?
This will help me delimit the groups.

Thank you kindly,
Apollo
 
Upvote 0
ApolloID,

When you respond to your helper, please use their site ID/username/handle.

This will keep thread clutter to a minimum and make the discussion easier to follow.

Did you even try my macro solution?
 
Upvote 0
hiker95 said:
When you respond to your helper, please use their site ID/username/handle.
Click to expand...
Hiker/Apollo, I agree entirely with this comment - it helps greatly if we know who is being addressed.



ApolloID said:
Please tell me, if it's possible to fill the "Total" row with color and also the bold text to have a color?
Click to expand...
If you are referring to my code, try making a change in the lower section as shown.
Rich (BB code): 
With .Columns("E:G").SpecialCells(xlFormulas).Offset(, 1)
  .FormulaR1C1 = "=RC[-1]/R" & lr & "C[-1]"
  .NumberFormat = "0%"
  <del>.EntireRow.Font.Bold = True</del>
  With Intersect(.EntireRow, .Parent.Columns("A:H"))
    .Font.Bold = True
    .Font.Color = vbBlue
    .Interior.Color = vbYellow
  End With
End With

.. the result:

Excel Workbook
ABCDEFGHI
1SupplierGroupCodDescriptionValue%Qty%
2supplier 1scissors 228scissor 13,781.191,614.00
3supplier 1scissors 259scissor 898,214.133,435.00
4supplier 1scissors 235scissor 331,989.64775
5scissor Total13,984.9657%582444%
6supplier 2tweezert 141tweezer 822,187.251,958.00
7supplier 2tweezert 222tweezer 1015,515.334,184.00
8supplier 2tweezert389tweezer 162,989.121,312.00
9tweezer Total10,691.7043%7,454.0056%
10Grand Total24,676.66100%13,278.00100%
11
Sheet1
 
Upvote 0
ApolloID,

fill the "Total" row with color and also the bold text to have a color?
Click to expand...

Thank you Peter_SSs.


After running my new macro the results will look like this:


Excel 2007
ABCDEFGH
1SupplierGroupCodDescriptionValue%Qty%
2supplier 1scissors 228scissor 13,781.191,614.00
3supplier 1scissors 259scissor 898,214.133,435.00
4supplier 1scissors 235scissor 331,989.64775
5scissor total13,984.9657%5,824.0044%
6supplier 2tweezert 141tweezer 822,187.251,958.00
7supplier 2tweezert 222tweezer 1015,515.334,184.00
8supplier 2tweezert389tweezer 162,989.121,312.00
9tweezer total10,691.7043%7,454.0056%
10
11Groups Total:24,676.66100%13,278.00100%
12
Sheet1
Cell Formulas
RangeFormula
E5=SUM(E2:E4)
E9=SUM(E6:E8)
G5=SUM(G2:G4)
G9=SUM(G6:G8)
F11=SUM(F2:F9)
H11=SUM(H2:H9)


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code: 
Sub ReorgData_V2()
' hiker95, 10/24/2014, ME813518
Dim g, i As Long
Dim r As Long, lr As Long
Dim Area As Range, sr As Long, er As Long
Dim etot As Double, gtot As Double
Application.ScreenUpdating = False
With Sheets("Sheet2")
  g = .Range("B2:B" & .Range("B" & Rows.Count).End(xlUp).Row)
End With
With Sheets("Sheet1")
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = 2 To lr
    For i = LBound(g) To UBound(g)
      If InStr(.Cells(r, 4), g(i, 1)) Then
        .Cells(r, 2).Value = g(i, 1)
        Exit For
      End If
    Next i
  Next r
  .Range("A2:H" & lr).Sort Key1:=.Range("B2"), Order1:=1, key2:=.Range("A2"), Order1:=1
  For r = lr To 3 Step -1
    If .Cells(r, 2).Value <> .Cells(r - 1, 2).Value Then .Rows(r).Insert
  Next r
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For Each Area In .Range("A2:A" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      With Cells(er + 1, 2)
        .Value = Cells(er, 2).Value & " total"
        .Font.Bold = True
      End With
      With Cells(er + 1, 5)
        .Value = "=SUM(E" & sr & ":E" & er & ")"
        .Font.Bold = True
        .NumberFormat = "#,##0.00"
      End With
      etot = etot + Cells(er + 1, 5)
      With Cells(er + 1, 7)
        .Value = "=SUM(G" & sr & ":G" & er & ")"
        .Font.Bold = True
        .NumberFormat = "#,##0.00"
      End With
      gtot = gtot + Cells(er + 1, 7)
      With Range("A" & er + 1 & ":H" & er + 1)
        .Font.Color = vbBlue
        .Interior.Color = vbYellow
      End With
    End With
  Next Area
  With Cells(er + 3, 2)
    .Value = "Groups Total:"
    .Font.Bold = True
  End With
  With Cells(er + 3, 5)
    .Value = etot
    .NumberFormat = "#,##0.00"
    .Font.Bold = True
  End With
  With Cells(er + 3, 7)
    .Value = gtot
    .NumberFormat = "#,##0.00"
    .Font.Bold = True
  End With
  With Range("A" & er + 3 & ":H" & er + 3)
    .Font.Color = vbBlue
    .Interior.Color = vbYellow
  End With
  For Each Area In .Range("A2:A" & lr).SpecialCells(xlCellTypeConstants).Areas
    With Area
      sr = .Row
      er = sr + .Rows.Count - 1
      With Cells(er + 1, 6)
        .Value = Cells(er + 1, 5) / etot
        .Font.Bold = True
        .NumberFormat = "0%"
      End With
      With Cells(er + 1, 8)
        .Value = Cells(er + 1, 7) / gtot
        .Font.Bold = True
        .NumberFormat = "0%"
      End With
    End With
  Next Area
  With Cells(er + 3, 6)
    .Value = "=SUM(F2:F" & lr + 1 & ")"
    .NumberFormat = "0%"
    .Font.Bold = True
  End With
  With Cells(er + 3, 8)
    .Value = "=SUM(H2:H" & lr + 1 & ")"
    .NumberFormat = "0%"
    .Font.Bold = True
  End With
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData_V2 macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Locked
  • Question
Macro - sorting by a specific word
Replies
1
Views
166
VoG
VoG

Forum statistics

Threads
1,215,220
Messages
6,123,693
Members
449,117
Latest member
Aaagu

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top