VBA - simple sort is killing me!

zookeepertx

zookeepertx

Well-known Member
Joined
May 27, 2011
Messages
567
Office Version
  1. 365
Platform
  1. Windows
Hello all!

This should be so easy, but not for me, apparently!
I have a table of data that can be of varying lengths and widths. My current macro does what I want - up to a point; that being to transpose the data and paste it in a new group underneath the current data. But then I want to sort it and that's where my problem comes in. The new info will always be pasted into column AE, starting in the third row below the raw data. The last row of raw data is represented by "lr"; the last column of raw data is represented by "LC". Once the 2nd table is created, the last row of that data is represented by "LR2" and the last column is the new value for "LC".

I've tried NUMEROUS versions of that part of my code and get various different errors each time. It's just a SORT; it should not be this hard!! I feel stupid!
Anyway, if someone can point out what I'm doing wrong, it would make me very happy, then I could move on to the next part of the macro.

Here is the code as I have it right now. I'll Bold/Underline where the error messages appear:
VBA Code: 
Sub MacroPOBI()
'JennyDrumm 082820
' MacroPOBI Macro

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Cells.Select
With Selection
    .WrapText = False
    .MergeCells = False
    .Font.Name = "Times"
End With

Columns("AH:AH").Delete Shift:=xlLeft

lr = Cells(Rows.count, 31).End(xlUp).Row
LC = Cells(12, Columns.count).End(xlToLeft).Column

With Range(Cells(12, 31), Cells(lr, LC)).Select
    Selection.Copy
    Cells(lr + 2, 31).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End With

LC = Cells(lr + 2, Columns.count).End(xlToLeft).Column
LR2 = Cells(Rows.count, 31).End(xlUp).Row

[B][U]Range(lr + 2 & ":" & LC).Sort Key1:=Range("AF" & lr.Row + 2), Order:=xlAscending, Key2:= _
    Range("AG" & lr.Row + 2), Order:=xlAscending[/U][/B]

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub


Here is what I have:

Capture1.JPG



Here is what I need:

Capture1b.JPG

Thank you for looking at this.

Jenny
 
Sort by date Sort by votes
Hi Try this with out Last Column and your Feedback is highly Appreciated (y)

VBA Code: 
Sub Macro1()
Dim Sht As Worksheet
Dim Rng As Range
Dim myRng As Range, SortRng As Range, ChrtRng As Range
Dim Arr As Variant
Dim R as long, C as long, N as long
Set Sht = ThisWorkbook.ActiveSheet
'Set Sht = ThisWorkbook.Worksheets("Name_of_sheet")

Set myRng = Sht.Range("AF12:AN12")
N = 0
R = myRng.Cells(1, 1).Row + 12
C = myRng.Cells(1, 1).Column

For Each Rng In myRng
If C - N = myRng.Cells(1, 1).Column Then
N = N + 1
Arr = Array("DC", "Store", "Total#" & Chr(10) & "Styles" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Dc", "", "", "", "", "")
With Sht.Cells(R - N, C)
    .Value = Arr(N)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With

End If
    With Sht.Cells(R, C - N + 1)
        .Interior.Color = Rng.Interior.Color
    End With
   
    With Sht.Cells(R, C - N + 1 + 1)
        .Value = Rng.Offset(1, 0).Value
        .Interior.Color = Rng.Offset(1, 0).Interior.Color
    End With
   
    With Sht.Cells(R, C - N + 1 + 2)
        .Value = Rng.Offset(2, 0).Value
        .Interior.Color = Rng.Offset(2, 0).Interior.Color
   
    End With
   
    With Sht.Cells(R, C - N + 1 + 3)
        .Value = WorksheetFunction.Sum(Rng.Offset(3, 0).Resize(6, 1))
        .Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color
   
    End With


R = R + 1
C = C + 1

Next
Set ChrtRng = myRng.Cells(1, 1).Offset(12, 0).Resize(9, 5)
Set SortRng = myRng.Cells(1, 2).Offset(12, 0)

    Sht.Sort.SortFields.Clear
    Sht.Sort.SortFields.Add2 Key:=SortRng, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sht.Sort
        .SetRange ChrtRng
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub




Book1
ADAEAFAGAHAIAJAKALAMAN
12Styleunit1002/NP1006/AT1009/NB1010/LA1012/SF1014/WC1019/MA1020/BN7088/DIR
13707970997099707770777099709970997088
14100210061009101010121014101910207088
151758871288879
162708771087779
17365776977769
184708710777710
1953581089
20635871089
21
22
23StoreTotal# Styles by StoreTotal# Units by StoreTotal# Units by Dc
247088/DIR7077101061
251012/SF7077101246
261010/LA7079100247
271020/BN7088708855
281006/AT7099100629
291002/NP7099100927
301009/NB7099101429
311014/WC7099101929
321019/MA7099102027
Sheet2
 
Upvote 0

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Edit
Hi
if like this you want feed me back
VBA Code: 
Sub Sort()

Dim Sht As Worksheet
Dim Rng As Range
Dim myRng As Range, SortRng As Range, ChrtRng As Range
Dim Arr As Variant
Dim R As Long, C As Long, N As Long
Set Sht = ThisWorkbook.ActiveSheet
''Set Sht = ThisWorkbook.Worksheets("Name_of_sheet")

Set myRng = Sht.Range("AF12:AN12")
N = 0
R = myRng.Cells(1, 1).Row + 12
C = myRng.Cells(1, 1).Column

For Each Rng In myRng
If C - N = myRng.Cells(1, 1).Column Then
N = N + 1
 Arr = Array("DC", "Store", "Total#" & Chr(10) & "Styles" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Dc", "", "", "", "", "")
With Sht.Cells(R - N, C)
    .Value = Arr(N - 1)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With

End If
    With Sht.Cells(R, C - N + 1)
        .Interior.Color = Rng.Interior.Color
    End With
    
    With Sht.Cells(R, C - N + 1 + 1)
        .Value = Rng.Offset(1, 0).Value
        .Interior.Color = Rng.Offset(1, 0).Interior.Color
    End With
    
    With Sht.Cells(R, C - N + 1 + 2)
        .Value = Rng.Offset(2, 0).Value
        .Interior.Color = Rng.Offset(2, 0).Interior.Color
    
    End With
    
    With Sht.Cells(R, C - N + 1 + 3)
        .Value = WorksheetFunction.Sum(Rng.Offset(3, 0).Resize(6, 1))
        .Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color
    
    End With
    With Sht.Cells(R, C - N + 1 + 4)
 
        .Value = Evaluate("SUMPRODUCT(" & myRng.Cells(1, 1).Offset(3, 0).Resize(6, myRng.Columns.Count).Address & "*(" & myRng.Cells(1, 1).Offset(1, 0).Resize(1, myRng.Columns.Count).Address & "=" & Rng.Offset(1, 0).Address & "))")
        .Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color
    
    End With


 R = R + 1
C = C + 1

Next
Set ChrtRng = myRng.Cells(1, 1).Offset(12, 0).Resize(9, 5)
Set SortRng = myRng.Cells(1, 2).Offset(12, 0)

    Sht.Sort.SortFields.Clear
    Sht.Sort.SortFields.Add2 Key:=SortRng, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sht.Sort
        .SetRange ChrtRng
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub



Book1.xlsm
ADAEAFAGAHAIAJAKALAMAN
12Styleunit1002/NP1006/AT1009/NB1010/LA1012/SF1014/WC1019/MA1020/BN7088/DIR
13707970997099707770777099709970997088
14100210061009101010121014101910207088
151758871288879
162708771087779
17365776977769
184708710777710
1953581089
20635871089
21
22
23DCStoreTotal# Styles by StoreTotal# Units by StoreTotal# Units by Dc
241009/NB7077101061107
251006/AT7077101246107
261014/WC707910024747
271002/NP708870885555
281012/SF7099100629141
291019/MA7099100927141
301020/BN7099101429141
317088/DIR7099101929141
321010/LA7099102027141
Sheet2
 
Upvote 0
Hello again!

MARK858 said:
Range(Cells(lr + 2, "AF"), Cells(LR2, LC)).Sort Key1:=Range("AF" & lr + 2), Order1:=xlAscending, Key2:= _ Range("AG" & lr + 2), Order2:=xlAscending
Click to expand...

This is from the last revision you suggested yesterday - the one that ALMOST worked completely. I made 2 small changes to it and now it seems to work perfectly! The "Range(Cells(lr +2, " had it including the header row in the results into the sort, so I changed it to lr + 3. That way it leaves the header as is and just sorts the data. The , "AF") had it sorting without using the data in AE, so I just changed that to AE so that that column gets included in the sort.
Here's the final code, in case you want to see it:

VBA Code: 
Sub POBI()
'MacroPOBI Macro

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

Cells.Select
With Selection
    .WrapText = False
    .MergeCells = False
    .Font.Name = "Times"
End With

Columns("AH:AH").Delete Shift:=xlLeft

lr = Cells(Rows.count, 31).End(xlUp).Row
LC = Cells(12, Columns.count).End(xlToLeft).Column

With Range(Cells(12, 31), Cells(lr, LC)).Select
    Selection.Copy
    Cells(lr + 2, 31).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End With

LC = Cells(lr + 3, Columns.count).End(xlToLeft).Column
LR2 = Cells(Rows.count, 31).End(xlUp).Row

Range(Cells(lr + 3, "AE"), Cells(LR2, LC)).Sort Key1:=Range("AF" & lr + 2), Order1:=xlAscending, Key2:= _
   Range("AG" & lr + 2), Order2:=xlAscending

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Now it works exactly as needed! YAY!! This makes me so happy! You're awesome for hanging in with me for so long and for coming up with just what was needed! Thank you, thank you!

Thank you.jpg


Jenny
 
Upvote 0
You're welcome

zookeepertx said:
had it including the header row in the results into the sort, so I changed it to lr + 3. That way it leaves the header as is and just sorts the data
Click to expand...

You could also have done ;)
Rich (BB code): 
Range(Cells(lr + 2, "AE"), Cells(LR2, LC)).Sort Key1:=Range("AF" & lr + 2), Order1:=xlAscending, Key2:= _
   Range("AG" & lr + 2), Order2:=xlAscending, Header:=xlYes
 
Upvote 0
That's true, but I was stressed and couldn't think of the syntax right then and was tired of googling stuff, LOL!
 
Upvote 0
Dossfm0q said:
Edit
Hi
if like this you want feed me back
VBA Code: 
Sub Sort()

Dim Sht As Worksheet
Dim Rng As Range
Dim myRng As Range, SortRng As Range, ChrtRng As Range
Dim Arr As Variant
Dim R As Long, C As Long, N As Long
Set Sht = ThisWorkbook.ActiveSheet
''Set Sht = ThisWorkbook.Worksheets("Name_of_sheet")

Set myRng = Sht.Range("AF12:AN12")
N = 0
R = myRng.Cells(1, 1).Row + 12
C = myRng.Cells(1, 1).Column

For Each Rng In myRng
If C - N = myRng.Cells(1, 1).Column Then
N = N + 1
Arr = Array("DC", "Store", "Total#" & Chr(10) & "Styles" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Dc", "", "", "", "", "")
With Sht.Cells(R - N, C)
    .Value = Arr(N - 1)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With

End If
    With Sht.Cells(R, C - N + 1)
        .Interior.Color = Rng.Interior.Color
    End With
   
    With Sht.Cells(R, C - N + 1 + 1)
        .Value = Rng.Offset(1, 0).Value
        .Interior.Color = Rng.Offset(1, 0).Interior.Color
    End With
   
    With Sht.Cells(R, C - N + 1 + 2)
        .Value = Rng.Offset(2, 0).Value
        .Interior.Color = Rng.Offset(2, 0).Interior.Color
   
    End With
   
    With Sht.Cells(R, C - N + 1 + 3)
        .Value = WorksheetFunction.Sum(Rng.Offset(3, 0).Resize(6, 1))
        .Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color
   
    End With
    With Sht.Cells(R, C - N + 1 + 4)

        .Value = Evaluate("SUMPRODUCT(" & myRng.Cells(1, 1).Offset(3, 0).Resize(6, myRng.Columns.Count).Address & "*(" & myRng.Cells(1, 1).Offset(1, 0).Resize(1, myRng.Columns.Count).Address & "=" & Rng.Offset(1, 0).Address & "))")
        .Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color
   
    End With


R = R + 1
C = C + 1

Next
Set ChrtRng = myRng.Cells(1, 1).Offset(12, 0).Resize(9, 5)
Set SortRng = myRng.Cells(1, 2).Offset(12, 0)

    Sht.Sort.SortFields.Clear
    Sht.Sort.SortFields.Add2 Key:=SortRng, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sht.Sort
        .SetRange ChrtRng
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub



Book1.xlsm
ADAEAFAGAHAIAJAKALAMAN
12Styleunit1002/NP1006/AT1009/NB1010/LA1012/SF1014/WC1019/MA1020/BN7088/DIR
13707970997099707770777099709970997088
14100210061009101010121014101910207088
151758871288879
162708771087779
17365776977769
184708710777710
1953581089
20635871089
21
22
23DCStoreTotal# Styles by StoreTotal# Units by StoreTotal# Units by Dc
241009/NB7077101061107
251006/AT7077101246107
261014/WC707910024747
271002/NP708870885555
281012/SF7099100629141
291019/MA7099100927141
301020/BN7099101429141
317088/DIR7099101929141
321010/LA7099102027141
Sheet2
Click to expand...

Hi there!
Thanks for your suggestion! I was able to adapt the previous code to get it to work, but I appreciate you looking at it.

Jenny
 
Upvote 0
zookeepertx said:
but I was stressed and couldn't think of the syntax right then
Click to expand...
Know the feeling, Btw you should also change the other 2's to 3's
Rich (BB code): 
Range(Cells(lr + 3, "AE"), Cells(LR2, LC)).Sort Key1:=Range("AF" & lr + 2), Order1:=xlAscending, Key2:= _
   Range("AG" & lr + 2), Order2:=xlAscending
 
Upvote 0
By Using Formula New

Book1.xlsm
ADAEAFAGAHAIAJAKALAMANAO
12Styleunit1002/NP1006/AT1009/NB1010/LA1012/SF1014/WC1019/MA1020/BN7088/DIR
13707970997099707770777099709970997088
14100210061009101010121014101910207088
151758871288879
162708771087779
17365776977769
184708710777710
1953581089
20635871089
21
22
23DCStoreTotal# Styles by StoreTotal# Units by StoreTotal# Units by DcUsing Formlua
241010/LA7077101061 
251012/SF7077101246107
261002/NP707910024747
277088/DIR708870885555
281006/AT7099100629 
291009/NB7099100927 
301014/WC7099101429 
311019/MA7099101929 
321020/BN7099102027141
33
Sheet2
Cell Formulas
RangeFormula
AF24:AF32AF24=INDEX($12:$12,AGGREGATE(15,6,COLUMN($AF$12:$AN$12)/($AF$13:$AN$13=AG24),COUNTIF(AG$24:AG24,AG24)))
AG24:AG32AG24=AGGREGATE(15,6,$AF$13:$AN$13,ROWS($AG$24:AG24))
AH24:AH32AH24=INDEX($14:$14,AGGREGATE(15,6,COLUMN($AF$14:$AN$14)/($AF$13:$AN$13=AG24),COUNTIF(AG$24:AG24,AG24)))
AI24:AI32AI24=SUM(IFERROR((AG24=$AF$13:$AN$13)/(AH24=$AF$14:$AN$14)*$AF$15:$AN$20,""))
AJ32,AJ24:AJ30AJ24=IF(COUNTIF($AG$24:$AG$32,AG24)=COUNTIF($AG$24:AG24,AG24),SUM(IFERROR((AG24=$AF$13:$AN$13)*$AF$15:$AN$20,"")),"")
AJ31AJ31=IF(COUNTIF($AG$24:$AG$32,AG31)=COUNTIF($AG$24:AG31,AG31),SUM(IFERROR((AG31=$AF$13:$AN$13)*$AF$15:$AN$20,"")),"")
Press CTRL+SHIFT+ENTER to enter array formulas.
Cells with Conditional Formatting
CellConditionCell FormatStop If True
AG33:AJ33Expression=$AF$33="7088/DIR"textNO
AG33:AJ33Expression=OR($AF$33="1010/LA",$AF$33="1012/SF")textNO
 
Upvote 0
Using VBA

add missing line now Ok
Sub SortKillingMe()
Dim Sht As Worksheet
Dim Rng As Range
Dim myRng As Range, SortRng As Range, ChrtRng As Range
Dim Arr As Variant
Dim R As Long, C As Long, N As Long
'Set Sht = ThisWorkbook.ActiveSheet
Set Sht = ThisWorkbook.Worksheets("Sheet6")

Set myRng = Sht.Range("AF12:AN12")
N = 0
R = myRng.Cells(1, 1).Row + 12
C = myRng.Cells(1, 1).Column

For Each Rng In myRng
If C - N = myRng.Cells(1, 1).Column Then
N = N + 1
Arr = Array("DC", "Store", "Total#" & Chr(10) & "Styles" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Store", "Total#" & Chr(10) & "Units" & Chr(10) & "by Dc", "", "", "", "", "")
With Sht.Cells(R - N, C)
.Value = Arr(N - 1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

End If
With Sht.Cells(R, C - N + 1 + 0)
.Value = Rng.Offset(0, 0).Value
.Interior.Color = Rng.Offset(0, 0).Interior.Color
End With
With Sht.Cells(R, C - N + 1 + 1)
.Value = Rng.Offset(1, 0).Value
.Interior.Color = Rng.Offset(1, 0).Interior.Color
End With

With Sht.Cells(R, C - N + 1 + 2)
.Value = Rng.Offset(2, 0).Value
.Interior.Color = Rng.Offset(2, 0).Interior.Color

End With

With Sht.Cells(R, C - N + 1 + 3)
.Value = WorksheetFunction.Sum(Rng.Offset(3, 0).Resize(6, 1))
.Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color

End With
With Sht.Cells(R, C - N + 1 + 4)

.Value = Evaluate("SUMPRODUCT(" & myRng.Cells(1, 1).Offset(3, 0).Resize(6, myRng.Columns.Count).Address & "*(" & myRng.Cells(1, 1).Offset(1, 0).Resize(1, myRng.Columns.Count).Address & "=" & Rng.Offset(1, 0).Address & "))")
.Interior.Color = Rng.Offset(3, 0).Resize(6, 1).Interior.Color

End With


R = R + 1
C = C + 1

Next
Set ChrtRng = myRng.Cells(1, 1).Offset(12, 0).Resize(9, 5)
Set SortRng = myRng.Cells(1, 2).Offset(12, 0)

Sht.Sort.SortFields.Clear
Sht.Sort.SortFields.Add2 Key:=SortRng, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sht.Sort
.SetRange ChrtRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
376
GarnesGambit
G
S
  • Solved
Transfer data from several workbooks to the main one
Replies
7
Views
394
eiloken
E
T
  • Question
Filter data in listbox based on three conditions by selected from combobox
Replies
1
Views
150
tubrak
T
S
  • Question
Scan Attendance
Replies
1
Views
258
Stewart11715
S
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
562
kevin9999
K

Forum statistics

Threads
1,214,403
Messages
6,119,308
Members
448,886
Latest member
GBCTeacher

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