Macro to sort

G

Guest

I wonder if anyone can help me, the senario is similar to my last one posted

"need to tailor macro code"

except sorting the column via company is not as simple. I shall explain why.

In this column there are reference numbers follower by the name of the
company say,

123456FDF78ALLEN
1234RTG5678PREST
123456SFDFDHYPER

However sometimes the refereence number is given with spaces between the
reference number and company i.e.
123456FDF78 ALLEN

this could be 1,2 or 3 spaces

Also for PREST sometimes it comes up in the spreadsheet PRESTIGE. I need the
macro to basically recognise and sort Via the company name so If it finds
ALLEN, HYPER or PREST it the groups it.



The code I have done is below but it doesnt seem to work,
Its sorts HYPER but not the other 2
Sub Quotelist()
'
' Quotelist Macro
' Macro recorded 13/07/2006 by terminal12
'

'

Dim cell As Range, rng As Range
Dim max1 As Long, max2 As Long, max3 As Long
Dim min1 As Long, min2 As Long, min3 As Long
min1 = 65536
min2 = 65536
min3 = 65536
Columns("B:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("G:K").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").ColumnWidth = 18.71
Range("B1").Select
Columns("A:A").ColumnWidth = 22.71
Columns("C:C").ColumnWidth = 14.29
Columns("G:G").ColumnWidth = 12.57
Range("A1").CurrentRegion.Sort _
Key1:=Range("F2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("O7").FormulaR1C1 = "AA Total"
Range("O8").FormulaR1C1 = "PR Total"
Range("O9").FormulaR1C1 = "HY Total"
Set rng = Range(Range("F2"), _
Cells(Rows.Count, "F").End(xlUp))
For Each cell In rng
Select Case Trim(cell.Value)
Case "ALLEN"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case " ALLEN"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case " ALLEN"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case " PREST"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case " PREST"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case "PREST"
If cell.Row < min2 Then min2 = cell.Row
If cell.Row > max2 Then max2 = cell.Row
Case "HYPER"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
Case " HYPER"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
Case " HYPER"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
Case "PRESTIGE"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
Case " PRESTIGE"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
Case " PRESTIGE"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row
End Select
Next
Range("P7").FormulaR1C1 = _
"=SUM(R" & min1 & "C4:R" & max1 & "C4)"
Range("P8").FormulaR1C1 = _
"=SUM(R" & min2 & "C4:R" & max2 & "C4)"
Range("P9").FormulaR1C1 = _
"=SUM(R" & min3 & "C4:R" & max3 & "C4)"

End Sub

Can you help me at all?

Regards

Barry
 
G

Guest

Sub Quotelist()
'
' Quotelist Macro
' Macro recorded 13/07/2006 by terminal12
'

'

Dim cell As Range, rng As Range
Dim max1 As Long, max2 As Long, max3 As Long
Dim min1 As Long, min2 As Long, min3 As Long
min1 = 65536
min2 = 65536
min3 = 65536
Columns("B:E").Select
Selection.Delete Shift:=xlToLeft
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("G:K").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").ColumnWidth = 18.71
Range("B1").Select
Columns("A:A").ColumnWidth = 22.71
Columns("C:C").ColumnWidth = 14.29
Columns("G:G").ColumnWidth = 12.57
Range("A1").CurrentRegion.Sort _
Key1:=Range("F2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("O7").FormulaR1C1 = "AA Total"
Range("O8").FormulaR1C1 = "PR Total"
Range("O9").FormulaR1C1 = "HY Total"
Set rng = Range(Range("F2"), _
Cells(Rows.Count, "F").End(xlUp))
For Each cell In rng
jj = 0
if instr(1,cell,"Hyp",vbtextcompare) then jj = 3
if instr(1,cell,"All",vbTextcompare) then jj = 1
if instr(1,cell,"Pre".vbTextcompare) then jj = 2
Select Case jj
Case 1 '"ALLEN"
If cell.Row < min1 Then min1 = cell.Row
If cell.Row > max1 Then max1 = cell.Row
Case 2 '"PREST"
If cell.Row < min2 Then min2 = cell.Row
If cell.Row > max2 Then max2 = cell.Row
Case 3 ' "HYPER"
If cell.Row < min3 Then min3 = cell.Row
If cell.Row > max3 Then max3 = cell.Row

End Select
Next
Range("P7").FormulaR1C1 = _
"=SUM(R" & min1 & "C4:R" & max1 & "C4)"
Range("P8").FormulaR1C1 = _
"=SUM(R" & min2 & "C4:R" & max2 & "C4)"
Range("P9").FormulaR1C1 = _
"=SUM(R" & min3 & "C4:R" & max3 & "C4)"

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Color Row Macro Problem, adapted from Patrick Malloy macro 4
Can't get code to work properly. Please Help! 2
MACRO COLUMNS, SKIP ROWS 6
MACRO PASTE CELL to COLUMN, SKIP ROWS 1
COPY...........(need a little change in a macro) 3
Useing IF to Paste a Range 3
Macro Suddenly Stopped Working 4
email several attachments (change to ron's macro?) 3

Top