Sort Descending

Hello Excel Gurus:

I need help for the revision of the VBA code below to sort DESCENDING on the “TR DATE “ (starting from cell Y7).

Any help would be appreciated.

Thank you.

Option Explicit
Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False
Application.ScreenUpdating = False

Dim Rng         As Range
Dim Dn          As Range
Dim Dic         As Object
Dim Temp        As String
Dim oCols       As String
Dim R           As Range
Dim C           As Long

Dim ws As Worksheet

With Sheets("Q-1")
  .EnableCalculation = False
End With

Set ws = Sheets("PubQ1")

   If Not Application.Intersect(Target, Range("C3")) Is Nothing Then
       Target(1).Value = UCase(Target(1).Value)
   End If
    
 With Sheets("dBase")
    Set Rng = .Range(.Range("J8"), .Range("J" & Rows.Count).End(xlUp))
 End With

Set Dic = CreateObject("scripting.dictionary")
    Dic.CompareMode = vbTextCompare
    
C = 7

For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn
    Else
        Set Dic.Item(Dn.Value) = Union(Dic.Item(Dn.Value), Dn)
    End If
Next

C = 7
    With Sheets("PubQ1")
       .Unprotect Password:="."
       .AutoFilterMode = False
       .Range(.Range("N6"), .Range("N" & Rows.Count).End(xlUp)).Resize(, 20).ClearContents
       .Range("N7").Resize(, 20).Value = Array("KEY DATE", "KEYED BY", "PUB/LOC/COMMENT", "PUB/LOC", "REC", "ISS", "ADJ QTY", "PICK QTY", "TR DATE", "PUB NO.", "DESCRIPTION", "TR DATE", "TR TYPE", "TR QTY", "PALLET", "ROW", "POS", "LEVEL", "UNI LOC", "COMMENT")
        If Dic.exists(.Range("C3").Value) Then
            For Each R In Dic.Item(.Range("C3").Value)
              C = C + 1
                .Range("N" & C).Resize(, 20).Value = R.Offset(, -9).Resize(, 20).Value  ‘I think revision is on this line will sort the result
            Next R
      End If
End With

 If Not Sheets("PubQ1").AutoFilterMode Then
  ws.Unprotect Password:="."
  ws.Range("A7:G7").AutoFilter
  ws.Protect _
        contents:=True, _
        AllowFiltering:=True, _
        UserInterfaceOnly:=True, _
        Password:="."
 End If
 
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Hello Leith Ross,

Here is the file that was requested.

The attached file has 2 sheets, dBase and PubQ1 sheet and has a working code. Type the pub number on cell “B3” and it will display KEY DATE, KEYED BY, TR DATE, TR TYPE, TR QTY, UNIFIED LOC and COMMENT coming from dBase sheet.

The revision I want is result to be sorted (descending) on the TR DATE and display only the 6 column (KEY DATE, KEYED BY, TR DATE, TR TYPE, etc.). As of now the column that I don’t want to show is just hidden.

Also, please check the code to set the print area is correct.

If the code has to be changed, it is most welcome. I have 25,000 rows and it runs slow.

Thank you and hope to receive your revision ASAP.

Thank you for your quick response and will let you know once i tested it. Happy thanksgiving.

Tested the code and it works but a little bit slow on 25K rows. I few more twerks i need on sheet "PubQ1" (if i may?)

The revisions i need:
1. When you type on cell "B3", i want it in all CAPS even if you type in small caps.
2. Keep formatting on destination cells (A8:G)
3. Always set filter from cell (A8:G) and
4. The sheet should be protected.

I am a newbie on macro code, so forgive me for my ignorance.

I hope you can help me again. Thank you...

Not sure about 2).

Sheet protected under "password"

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "B3" Then Exit Sub
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Me.Unprotect "password"
    [a7].CurrentRegion.Offset(1).ClearContents
    If Target <> "" Then
        Target.Value = UCase$(Target.Value)
        With Sheets("dbase")
            With .Range("a6", .Cells.SpecialCells(11))
                .Parent.AutoFilterMode = False
                .AutoFilter 10, Target
                With .Offset(1)
                    Union(.Columns("a:b"), .Columns("i"), .Columns("m:n"), _
                            .Columns("s:t")).Copy
                    [a8].PasteSpecial xlPasteValues
                    If Not Me.AutoFilterMode Then [a7].CurrentRegion.AutoFilter
                    Target(2).Select
                End With
                .AutoFilter
            End With
        End With
    End If
    [a7].CurrentRegion.Sort [c7], 2, , , , , , True
    Me.Protect "password", , , , , , , , , , , , , , True
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Hello again,
It works perfectly for my needs, two more request.
1. Can you add a second sort? UNIFIED LOC (ascending)
2. Cell B3 is merge with C3 and D4 and it does not clear A8:G when cell B3 is blank.

Just for curiosity:
CurrentRegion has 6 commas between 2 and True, what does it represent.
Likewise, me.Protect... has 14 commas,
Please educate me.

Thank you...



QUOTE=jindon;4247948]Not sure about 2).

Sheet protected under "password"

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "B3" Then Exit Sub
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Me.Unprotect "password"
    [a7].CurrentRegion.Offset(1).ClearContents
    If Target <> "" Then
        Target.Value = UCase$(Target.Value)
        With Sheets("dbase")
            With .Range("a6", .Cells.SpecialCells(11))
                .Parent.AutoFilterMode = False
                .AutoFilter 10, Target
                With .Offset(1)
                    Union(.Columns("a:b"), .Columns("i"), .Columns("m:n"), _
                            .Columns("s:t")).Copy
                    [a8].PasteSpecial xlPasteValues
                    If Not Me.AutoFilterMode Then [a7].CurrentRegion.AutoFilter
                    Target(2).Select
                End With
                .AutoFilter
            End With
        End With
    End If
    [a7].CurrentRegion.Sort [c7], 2, , , , , , True
    Me.Protect "password", , , , , , , , , , , , , , True
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

[/QUOTE]