sort names based on alphabet doesn't work

leap out

Board Regular
Joined
Dec 4, 2020
Messages
114
Office Version
  1. 2016
  2. 2010
hi
I have this macro doesn't work in cells a1 is dropdown I would sort based alphabet for instance if the list contains asd1,asd2,asd3 bbd,bdd1,bbb2 ,cdd,ccd,ccc
so should the list like this
asd1
asd2
asd3
bbb2
bbd1
bdd1
ccc
ccd
cdd
another thing I would when write in cells a1 manually for instance asd1 then show list
asd1
asd2
asd3
VBA Code:
Sub Sort_B()
    With Sheets("sort").UsedRange
        .Sort Key1:=.Range("a1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    End With
End Sub
note: if is possible do the macro without button automatically
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
What about
sort less.xlsx
AB
1
2asd2asd1
3asd1asd2
4asd3asd3
5bbb2bbb2
6bbd2bbd1
7bdd1bbd2
8cccbdd1
9ccdccc
10cddccd
11bbd1cdd
Sheet5
Cell Formulas
RangeFormula
B2:B11B2=IFERROR(INDEX($A$2:$A$20,AGGREGATE(15,6,TRANSPOSE(((ROW($A$2:$A$20)-ROW($A$2))+((COLUMN($A$2:$A$20)-COLUMN($A$2))*ROWS($A$2:$A$20)+1)))/(TRANSPOSE(COUNTIF($A$2:$A$20,"<"&$A$2:$A$20)+($A$2:$A$20<>"")+(--(ISNUMBER($A$2:$A$20)=FALSE))*(SUMPRODUCT(--(ISNUMBER($A$2:$A$20)=TRUE))+0)-SUMPRODUCT(COUNTIF($A$2:$A$20,B$1:B1)))=1),1)),"")
Press CTRL+SHIFT+ENTER to enter array formulas.
 

leap out

Board Regular
Joined
Dec 4, 2020
Messages
114
Office Version
  1. 2016
  2. 2010
thanks but I want by code you know why because I have dropdown when I write manually in a1 should autocomplete like this picture then I get some data from another sheet
 

Attachments

  • doc-drop-down-list-autocomplete8.png
    doc-drop-down-list-autocomplete8.png
    6.9 KB · Views: 2

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
auto
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WB As Workbook
Dim WS As Worksheet
Dim LstRw As Long
Dim Rng As Range

Set WB = ThisWorkbook
Set WS = WB.ActiveSheet

    LstRw = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    Set Rng = ThisWorkbook.ActiveSheet.Cells(1, 1).Resize(LstRw, 1)
  
    WS.Sort.SortFields.Clear
    WS.Sort.SortFields.Add2 Key:=Rng.Cells(2, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With WS.Sort
        .SetRange Rng
        .Header = xlYes 'xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 

leap out

Board Regular
Joined
Dec 4, 2020
Messages
114
Office Version
  1. 2016
  2. 2010

ADVERTISEMENT

it gives me error "object doesn't support this property or method" in this line
VBA Code:
    WS.Sort.SortFields.Add2 Key:=Rng.Cells(2, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
 

leap out

Board Regular
Joined
Dec 4, 2020
Messages
114
Office Version
  1. 2016
  2. 2010

ADVERTISEMENT

me too , what's wrong ? :eek:
 

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
try this will create a file with dropdown and auto sort

VBA Code:
Sub sort_names_based_on_alphabet()

Dim NWB As Workbook
Dim WS As Worksheet
   Set NWB = Workbooks.Add
  
   With NWB
    Set WS = .Worksheets(1)
        With WS
        
            With .Range("A2:A10")
            .Value = [{"asd1";"asd2";"asd3";"bbb2";"bbd1";"bdd1";"ccc";"ccd";"cdd"}]
            End With
            
            With .Range("B2:B20")
                    With .Interior
                        .Pattern = xlSolid
                        .Color = RGB(255, 250, 245)
                    End With
                    With .Validation
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                        xlBetween, Formula1:="=OFFSET($A$2,0,0,COUNTA(A:A),1)"
                    End With
                    .Cells(2, 1).Activate
            End With
        
        End With
        
   End With
    
    On Error Resume Next
       ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3

        NWB.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3

        
    On Error GoTo 0
        Call AddAutoSortProcedure(NWB)
End Sub
    Sub AddAutoSortProcedure(WB As Workbook)
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """" ' one " character

        Set VBProj = WB.VBProject
        Set VBComp = VBProj.VBComponents("Sheet1")
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc("Change", "Worksheet")
            LineNum = LineNum + 1
            .InsertLines LineNum, "Dim KyRng As Range, SrtRng As Range" & Chr(10) & "Dim LstRw As Long" & Chr(10) & "    With Target.Parent" & Chr(10) & "        LstRw = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row" & Chr(10) & "        Set KyRng = .Cells(1, 1).Resize(LstRw, 1)" & Chr(10) & "        Set SrtRng = .Cells(2, 1).Resize(LstRw, 1)" & Chr(10) & "           .Sort.SortFields.Clear" & Chr(10) & "           '.Sort.SortFields.Add2 Key:=KyRng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOpti" & _
                                  "on:=xlSortNormal ''' or below" & Chr(10) & "           .Sort.SortFields.Add2 Key:=Range(""A1:A20""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal" & Chr(10) & "           " & Chr(10) & "           With .Sort" & Chr(10) & "               '.SetRange SrtRng ''' or below" & Chr(10) & "               .SetRange Range(""A2:A20"")" & Chr(10) & "               .Header = xlNo" & Chr(10) & "               .MatchCase = False" & Chr(10) & "               .Orientat" & _
                                  "ion = xlTopToBottom" & Chr(10) & "               .SortMethod = xlPinYin" & Chr(10) & "               .Apply" & Chr(10) & "           End With" & Chr(10) & "    End With"

        End With
    End Sub
 

leap out

Board Regular
Joined
Dec 4, 2020
Messages
114
Office Version
  1. 2016
  2. 2010
actually it add a new workbook and create dropdown in column b and the names in column a as your code after this it shows error " subscript out of range " , but I no know where is exactly the line, because the button debug is inactive also when I write in column b to search specific item it doesn't auto complete the names
 

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Code:
Sub sort_names_based_on_alphabet()

    Dim NWB As Workbook
    Dim WS As Worksheet
    Dim DropList As OLEObject
    Dim ISExst As OLEObject
    Dim LstRng As Range
    Dim LstRw As Long
    Dim I As Integer
    Dim Prcdr1 As String, Prcdr2 As String, Prcdr3 As String
    Dim IsEX As Boolean
        Set NWB = Workbooks.Add
            With NWB
            Set WS = NWB.ActiveSheet
                With WS
                .Cells.RowHeight = 17
                    With .Range("A2:A10")
                    .Value = [{"asd1";"asd2";"asd3";"bbb2";"bbd1";"bdd1";"ccc";"ccd";"cdd"}]
                    End With
                LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row - 1
                Set LstRng = .Cells(2, 1).Resize(LstRw, 1)
                On Error Resume Next
                Set ISExst = .OLEObjects("DropList")
                    If ISExst Is Nothing Then
                        Set DropList = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", link:=False, DisplayAsIcon:=False, Left:=.Cells(1, 2).Left, Top:=50, Width:=.Cells(1, 2).Width, Height:=18)
                        With DropList
                            .Name = "DropList"
                            .ListFillRange = LstRng.Address(True, True)
                            .LinkedCell = Target.Address(True, True)
                            .Visible = False
                        End With 'DropList
                    Else
                    End If
                    
                On Error GoTo 0
                End With 'WS
            End With 'NWB
            
            IsEX = False
            With ThisWorkbook.VBProject.References
                For I = 1 To .Count
                   If .Item(I).GUID = "{0002E157-0000-0000-C000-000000000046}" Then
                   IsEX = True
                        Exit For
                    
                    End If
                Next
            If IsEX = False Then .AddFromGuid GUID:="{0002E157-0000-0000-C000-000000000046}", Major:=5, Minor:=3
            End With
            
            IsEX = False
            With NWB.VBProject.References
                For I = 1 To .Count
                    If .Item(I).GUID = "{0002E157-0000-0000-C000-000000000046}" Then
                        Exit For
                        
                    End If
                Next
            If IsEX = False Then .AddFromGuid GUID:="{0002E157-0000-0000-C000-000000000046}", Major:=5, Minor:=3
            End With
            Prcdr1 = "    Dim DropList As OLEObject" & vbNewLine & _
                    "    On Error Resume Next" & vbNewLine & _
                    "        Set DropList = Me.OLEObjects(""DropList"")" & vbNewLine & _
                    "            With DropList" & vbNewLine & _
                    "            .Visible = False" & vbNewLine & _
                    "            End With" & vbNewLine & _
                    "    On Error GoTo 0"
            
            Prcdr2 = "    Dim DropList As OLEObject" & vbNewLine & _
                    "    On Error Resume Next" & vbNewLine & _
                    "    Application.EnableEvents = False" & vbNewLine & _
                    "    If Not Intersect(Target, Range(""B2:E100"")) Is Nothing Then" & vbNewLine & _
                    "     Set DropList = Target.Parent.OLEObjects(""DropList"")" & vbNewLine & _
                    "        With DropList" & vbNewLine & _
                    "           .Left = Target.Left" & vbNewLine & _
                    "           .Top = Target.Top" & vbNewLine & _
                    "           .Width = Target.Width" & vbNewLine & _
                    "           .Height = Target.Height" & vbNewLine & _
                    "           .LinkedCell = Target.Address(True, True)" & vbNewLine & _
                    "           .Visible = True" & vbNewLine & _
                    "        End With" & vbNewLine & _
                    "    else" & vbNewLine & _
                    "    " & vbNewLine & _
                    "    End If" & vbNewLine & _
                    "    Application.EnableEvents = True" & vbNewLine & _
                    "    On Error GoTo 0"
                    
            Prcdr3 = "Dim KyRng As Range, SrtRng As Range" & vbNewLine & _
                    "Dim LstRw As Long" & vbNewLine & _
                    "    If Not Intersect(Target, Columns(1)) Is Nothing Then" & vbNewLine & _
                    "    With Target.Parent" & vbNewLine & _
                    "        LstRw = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row" & vbNewLine & _
                    "        Set KyRng = .Cells(1, 1).Resize(LstRw, 1)" & vbNewLine & _
                    "        Set SrtRng = .Cells(2, 1).Resize(LstRw, 1)" & vbNewLine & _
                    "           .Sort.SortFields.Clear" & vbNewLine & _
                    "           .Sort.SortFields.Add2 Key:=KyRng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ''' or below" & vbNewLine & _
                    "           '.Sort.SortFields.Add2 Key:=Range(""A1:A50""), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal" & vbNewLine & _
                    "           " & vbNewLine & _
                    "           With .Sort" & vbNewLine & _
                    "               .SetRange SrtRng ''' or below" & vbNewLine & _
                    "               '.SetRange Range(""A2:50"")" & vbNewLine & _
                    "               .Header = xlNo" & vbNewLine & _
                    "               .MatchCase = False" & vbNewLine & _
                    "               .Orientation = xlTopToBottom" & vbNewLine & _
                    "               .SortMethod = xlPinYin" & vbNewLine & _
                    "               .Apply" & vbNewLine & _
                    "           End With" & vbNewLine & _
                    "    End With" & vbNewLine & _
                    "    else" & vbNewLine & _
                    "    " & vbNewLine & _
                    "    End If"
        
           Call AddAutoSortProcedure(NWB, "Sheet1", "Click", "DropList", Prcdr1)
           Call AddAutoSortProcedure(NWB, "Sheet1", "SelectionChange", "Worksheet", Prcdr2)
           Call AddAutoSortProcedure(NWB, "Sheet1", "Change", "Worksheet", Prcdr3)

End Sub
Sub AddAutoSortProcedure(WB As Workbook, moduleName As String, EventName As String, ObjName As String, Prcdr As String)
        Dim VBProj As VBIDE.VBProject
        Dim VBComp As VBIDE.VBComponent
        Dim CodeMod As VBIDE.CodeModule
        Dim LineNum As Long
        Const DQUOTE = """"
        Set VBProj = WB.VBProject
        Set VBComp = VBProj.VBComponents(moduleName)
        Set CodeMod = VBComp.CodeModule
        
        With CodeMod
            LineNum = .CreateEventProc(EventName, ObjName)
            LineNum = LineNum + 1
            .InsertLines LineNum, Prcdr
        End With
        
End Sub


sort_names_based_on_alphabet.gif
 

Watch MrExcel Video

Forum statistics

Threads
1,129,522
Messages
5,636,816
Members
416,942
Latest member
kitkat22

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
Top