VBA - simple sort is killing me!

zookeepertx

Active Member
Joined
May 27, 2011
Messages
480
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
 

Dossfm0q

Active Member
Joined
Mar 9, 2009
Messages
405
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:

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

zookeepertx

Active Member
Joined
May 27, 2011
Messages
480
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

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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,651
Messages
5,549,204
Members
410,905
Latest member
Extjel
Top