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
