VBA - simple sort is killing me!

zookeepertx

zookeepertx

Well-known Member
Joined
May 27, 2011
Messages
576
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
Greetings
if you need this, will set up Formula and condition
on your Table, you can delete some repeated lines or duplicated

Thanks

VBA Code: 
Public Sub AddFormulatoSort()

Dim Sht As Worksheet
Dim Rng As Range
Dim MainTblRng As Range
Dim TRNSPSRng As Range 'TRANSPOSED Data
Dim TRNSPSRngHdr As Range 'TRANSPOSED Header
Dim TRNSPSRngBdy As Range 'TRANSPOSED Body


Set Sht = ThisWorkbook.ActiveSheet
'Set Sht = ThisWorkbook.Worksheets("Sheet2")' change

Set MainTblRng = Sht.Range("AD12:AN20")
Dim StrtRw As Long, StrtCl As Long
With MainTblRng
Set TRNSPSRng = .Cells(1, 3).Resize(.Rows.Count, .Columns.Count - 2)
End With

Set TRNSPSRngHdr = TRNSPSRng.Rows("1:3").Cells
Set TRNSPSRngBdy = TRNSPSRng.Rows("4:" & TRNSPSRng.Rows.Count).Cells

StrtRw = MainTblRng.Row + MainTblRng.Rows.Count + 3
StrtCl = TRNSPSRng.Column
Sht.Cells.FormatConditions.Delete
For Each Rng In TRNSPSRng.Rows("1:5").Cells

With Sht
    With .Cells(StrtRw + (Rng.Column - StrtCl), StrtCl + (Rng.Row - MainTblRng.Row))
        If Rng.Row - TRNSPSRngHdr.Row = 0 Then
           Rngs1Entr = TRNSPSRngHdr.EntireRow(1).Address
           Rngs2Entr = TRNSPSRngHdr.EntireRow(2).Address
           Rngs3Entr = TRNSPSRngHdr.EntireRow(3).Address
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column + 1).Address(False, False)
            RngRws = Cells(StrtRw, .Column + 1).Address & ":" & Meost & "," & Meost
            .Formula = "=INDEX(" & Rngs1Entr & ",AGGREGATE(15,6,COLUMN(" & Rngs1 & ")/(" & Rngs2 & "=" & Meost & "),COUNTIF(" & RngRws & ")))"
            Meadrs = .Address
            With .Offset(0, 1).Resize(1, 4)
            
                .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(" & Meadrs & "=""1010/LA""," & Meadrs & "=""1012/SF"")"
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1).Interior
              
                .Color = RGB(145, 205, 80)
                End With
                .FormatConditions(1).StopIfTrue = False
               ''''''''''''''''''
                .FormatConditions.Add Type:=xlExpression, Formula1:="=" & Meadrs & "=""7088/DIR"""
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1).Interior
                    .Color = RGB(190, 215, 240)
                End With
                .FormatConditions(1).StopIfTrue = False
              
              
              
             End With
      
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 1 Then
          
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            RngRws = Cells(StrtRw, .Column).Address & ":" & Cells(.Row, .Column).Address(False, False)
            .Formula = "=AGGREGATE(15,6," & Rngs2 & ",ROWS(" & RngRws & "))"
      
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 2 Then
          
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column - 1).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 1).Address & ":" & Meost & "," & Meost
            .Formula = "=INDEX(" & Rngs3Entr & ",AGGREGATE(15,6,COLUMN(" & Rngs3 & ")/(" & Rngs2 & "=" & Meost & "),COUNTIF(" & RngRws & ")))"
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 3 Then
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column - 1).Address(False, False)
            Meost1 = Cells(.Row, .Column - 2).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 1).Address & ":" & Meost & "," & Meost
        .Formula = "=SUMPRODUCT((" & Meost1 & "=" & Rngs2 & ")*(" & Meost & "=" & Rngs3 & ")*" & TRNSPSRngBdy.Address & ")"
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 4 Then
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Meost1 = Cells(.Row, .Column - 3).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 3).Address & ":" & Meost1 & "," & Meost1
            TtlRngRws = Cells(StrtRw, .Column - 3).Resize(TRNSPSRngHdr.Columns.Count, 1).Address
        .Formula = "=IF(COUNTIF(" & TtlRngRws & "," & Meost1 & ")=COUNTIF(" & RngRws & "),SUMPRODUCT((" & Meost1 & "=" & Rngs2 & ")*" & TRNSPSRngBdy.Address & "),"""")"
        '
        End If
    End With
End With

Next





End Sub
 
Last edited:
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Dossfm0q said:
Greetings
if you need this, will set up Formula and condition
on your Table, you can delete some repeated lines or duplicated

Thanks

VBA Code: 
Public Sub AddFormulatoSort()

Dim Sht As Worksheet
Dim Rng As Range
Dim MainTblRng As Range
Dim TRNSPSRng As Range 'TRANSPOSED Data
Dim TRNSPSRngHdr As Range 'TRANSPOSED Header
Dim TRNSPSRngBdy As Range 'TRANSPOSED Body

Set Sht = ThisWorkbook.ActiveSheet
'Set Sht = ThisWorkbook.Worksheets("Sheet2")' change

Set MainTblRng = Sht.Range("AD12:AN20")
Dim StrtRw As Long, StrtCl As Long
With MainTblRng
Set TRNSPSRng = .Cells(1, 3).Resize(.Rows.Count, .Columns.Count - 2)
End With

Set TRNSPSRngHdr = TRNSPSRng.Rows("1:3").Cells
Set TRNSPSRngBdy = TRNSPSRng.Rows("4:" & TRNSPSRng.Rows.Count).Cells

StrtRw = MainTblRng.Row + MainTblRng.Rows.Count + 3
StrtCl = TRNSPSRng.Column
Sht.Cells.FormatConditions.Delete
For Each Rng In TRNSPSRng.Rows("1:5").Cells

With Sht
    With .Cells(StrtRw + (Rng.Column - StrtCl), StrtCl + (Rng.Row - MainTblRng.Row))
        If Rng.Row - TRNSPSRngHdr.Row = 0 Then
           Rngs1Entr = TRNSPSRngHdr.EntireRow(1).Address
           Rngs2Entr = TRNSPSRngHdr.EntireRow(2).Address
           Rngs3Entr = TRNSPSRngHdr.EntireRow(3).Address
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column + 1).Address(False, False)
            RngRws = Cells(StrtRw, .Column + 1).Address & ":" & Meost & "," & Meost
            .Formula = "=INDEX(" & Rngs1Entr & ",AGGREGATE(15,6,COLUMN(" & Rngs1 & ")/(" & Rngs2 & "=" & Meost & "),COUNTIF(" & RngRws & ")))"
            Meadrs = .Address
            With .Offset(0, 1).Resize(1, 4)
           
                .FormatConditions.Add Type:=xlExpression, Formula1:="=OR(" & Meadrs & "=""1010/LA""," & Meadrs & "=""1012/SF"")"
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1).Interior
             
                .Color = RGB(145, 205, 80)
                End With
                .FormatConditions(1).StopIfTrue = False
               ''''''''''''''''''
                .FormatConditions.Add Type:=xlExpression, Formula1:="=" & Meadrs & "=""7088/DIR"""
                .FormatConditions(.FormatConditions.Count).SetFirstPriority
                With .FormatConditions(1).Interior
                    .Color = RGB(190, 215, 240)
                End With
                .FormatConditions(1).StopIfTrue = False
             End With
     
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 1 Then
         
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            RngRws = Cells(StrtRw, .Column).Address & ":" & Cells(.Row, .Column).Address(False, False)
            .Formula = "=AGGREGATE(15,6," & Rngs2 & ",ROWS(" & RngRws & "))"
     
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 2 Then
         
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column - 1).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 1).Address & ":" & Meost & "," & Meost
            .Formula = "=INDEX(" & Rngs3Entr & ",AGGREGATE(15,6,COLUMN(" & Rngs3 & ")/(" & Rngs2 & "=" & Meost & "),COUNTIF(" & RngRws & ")))"
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 3 Then
            Rngs1 = TRNSPSRngHdr.Rows("1:1").Cells.Address
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Rngs3 = TRNSPSRngHdr.Rows("3:3").Cells.Address
            Meost = Cells(.Row, .Column - 1).Address(False, False)
            Meost1 = Cells(.Row, .Column - 2).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 1).Address & ":" & Meost & "," & Meost
        .Formula = "=SUMPRODUCT((" & Meost1 & "=" & Rngs2 & ")*(" & Meost & "=" & Rngs3 & ")*" & TRNSPSRngBdy.Address & ")"
        ElseIf Rng.Row - TRNSPSRngHdr.Row = 4 Then
            Rngs2 = TRNSPSRngHdr.Rows("2:2").Cells.Address
            Meost1 = Cells(.Row, .Column - 3).Address(False, False)
            RngRws = Cells(StrtRw, .Column - 3).Address & ":" & Meost1 & "," & Meost1
            TtlRngRws = Cells(StrtRw, .Column - 3).Resize(TRNSPSRngHdr.Columns.Count, 1).Address
        .Formula = "=IF(COUNTIF(" & TtlRngRws & "," & Meost1 & ")=COUNTIF(" & RngRws & "),SUMPRODUCT((" & Meost1 & "=" & Rngs2 & ")*" & TRNSPSRngBdy.Address & "),"""")"
        '
        End If
    End With
End With

Next

End Sub
Click to expand...

Hi there!

Sorry for the late reply; it's been hectic around here.

Wow! That's amazing! That does exactly what I need!

The only thing I'm wondering is whether it will adapt to different amounts of data. What I mean is that I never know how many rows or columns might be in a given worksheet. The data will always start in AE12, but there could be any number of stores (columns) or styles (rows). I've been sitting here trying to get that last column - the one consolidating each DC - to give the correct answer by using LC and LR but it's been failing miserably.

Also - and this would totally be icing on the cake; it doesn't need to happen - would it be possible to put a border around the data belonging to each DC. (Like the top 2 rows for DC 7077; a border around AF24 - AJ25). Just to give a visual distinction between the DCs. Like I said, that would honestly be just an extra that's not necessary.

I don't have the SLIGHTEST clue how your code works, LOL! Is there ANY chance - just if you have time - that you could break it down for me? I like to be able to understand what different code means in case I need to use it later. Again, this is also just if you have the time.

Thank you!! This is great!

Jenny
 
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
491
GarnesGambit
G
S
  • Solved
Transfer data from several workbooks to the main one
Replies
7
Views
424
eiloken
E
T
  • Question
Filter data in listbox based on three conditions by selected from combobox
Replies
1
Views
220
tubrak
T
S
  • Question
Scan Attendance
Replies
1
Views
304
Stewart11715
S
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
719
kevin9999
K

Forum statistics

Threads
1,215,671
Messages
6,126,131
Members
449,293
Latest member
yallaire64

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