我有下面的代碼，用于洗掉重復項并將值按字母順序排序到用戶表單中的串列框中，但它優先考慮大寫字母而不是字母，我希望它忽略文本的大小寫
Dim Coll As Collection, cell As Range, LastRow As Long
Dim blnUnsorted As Boolean, i As Integer, temp As Variant
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets("Groups")
'///////////////////////////////////////////////////////
'Populate the ListBox with unique Make items from column A.
LastRow = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set Coll = New Collection
'Open a With structure for the ListBox control.
With ClientInput
.Clear
For Each cell In SourceSheet.Range("A2:A" & LastRow)
'Only attempt to populate cells containing a text or value.
If Len(cell.Value) <> 0 Then
Err.Clear
Coll.Add cell.Text, cell.Text
If Err.Number = 0 Then .AddItem cell.Text
End If
Next cell
blnUnsorted = True
Do
blnUnsorted = False
For i = 0 To UBound(.List) - 1
If .List(i) > .List(i 1) Then
temp = .List(i)
.List(i) = .List(i 1)
.List(i 1) = temp
blnUnsorted = True
Exit For
End If
Next i
Loop While blnUnsorted = True
'Close the With structure for the ListBox control.
End With
當前的
交流電
AZ
抗體
期望的
抗體
交流電
AZ
uj5u.com熱心網友回復：
您可以使用作業表功能sort
這是如何使用它的示例代碼
Sub sortRange()
Dim rg As Range: Set rg = Selection
Dim arrValues As Variant
arrValues = WorksheetFunction.Sort(rg)
rg.Offset(, 2).Resize(3).Value = arrValues
End Sub
如果選擇 A1:A3，上述代碼會將排序后的值寫入 C1:C3
您可以遍歷陣列以將專案添加到串列中
uj5u.com熱心網友回復：
代替
If .List(i) > .List(i 1) Then
利用
If LCase(.List(i)) > LCase(.List(i 1)) Then
uj5u.com熱心網友回復：
請嘗試下一個代碼。它首先將現有范圍（來自 A:A）放在一個陣列中，對范圍進行就地排序，將排序后的范圍放在另一個陣列中，使用 a 提取唯一字串（區分大小寫），Dictionary并使用其直接從陣列中加載串列框List財產。然后，在排序之前放回初始提取的陣列：
Sub UniqueSortLoadListBox()
Dim sh As Worksheet, lastR As Long, arr, arrSort, i As Long, dict As Object
Set sh = Worksheets("Groups")
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:A" & lastR).Value
With sh.Sort 'the fastest sorting way
.SortFields.Clear
.SortFields.Add2 Key:=sh.Range("A1:A" & lastR), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange sh.Range("A1:A" & lastR)
.Header = xlYes
.MatchCase = True
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row ' recalculate to eliminate the empty cells
arrSort = sh.Range("A2:A" & lastR).Value 'place the sorted range in an array, for faster iteration/processing
'extract unique strings (case sensitive)
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = BinaryCompare 'case sensitive for keys creation
For i = 1 To UBound(arrSort)
dict(arrSort(i, 1)) = 1
Next i
'load the listbox directly from an array (dictionary keys array)
With clientInput
.Clear
.List = dict.Keys
End With
'place back the array as it was before sorting and unique extracting:
sh.Range("A2").Resize(UBound(arr), 1).Value = arr
End Sub
請在測驗后發送一些反饋。
uj5u.com熱心網友回復：
將列值排序到串列框
如果你沒有 365
- 簡而言之，代碼會將條件列中的值寫入輔助列，該列與已使用范圍的右側相鄰，對其進行排序，檢索其值，清除其內容，并使用檢索到的唯一值填充串列框（排序）值。
Sub PopulateClientInput()
Const ProcTitle As String = "Populate Client Input"
' Define constants.
Const wsName As String = "Groups"
Const cCol As Long = 1
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' It is assumed that the worksheet's used range consists of a valid table
' (not an Excel table) i.e. one row of headers and contiguous data below.
' Reference the expanded data range ('rg') i.e. the data range (no headers)
' and an extra helper column to the right. Retrieve the range's
' number of rows ('rCount') and columns ('cCount').
Dim rg As Range
Dim rCount As Long
Dim cCount As Long
With ws.UsedRange
rCount = .Rows.Count - 1 ' shrink
If rCount = 0 Then ' only headers or empty worksheet
MsgBox "Not enough rows.", vbExclamation, ProcTitle
Exit Sub
End If
cCount = .Columns.Count 1 ' expand
' Note that the following cannot happen if 'cCol = 1'.
If cCount < cCol 1 Then ' criteria column not in used range
MsgBox "Not enough columns.", vbExclamation, ProcTitle
Exit Sub
End If
' Reference the range.
Set rg = .Resize(rCount, cCount).Offset(1)
End With
' Reference the criteria column range ('crg').
Dim crg As Range: Set crg = rg.Columns(cCol)
' Store the sorted values from the criteria column range
' in a 2D one-based (one-column) array, the criteria array ('cData').
Application.ScreenUpdating = False
Dim cData() As Variant
If rCount > 1 Then ' multiple cells
' Reference the helper column range ('hrg').
Dim hrg As Range: Set hrg = rg.Columns(cCount)
' Write the values from the criteria column range
' to the helper column range.
hrg.Value = crg.Value
' Sort the helper column range.
hrg.Sort hrg, xlAscending, , , , , , xlNo
' Store the sorted values from the sorted helper column range
' in the criteria array.
cData = hrg.Value
' Clear the contents of the helper column range.
hrg.ClearContents
Else ' one cell
' Store the single value in the single element of the criteria array.
ReDim cData(1 To 1, 1 To 1): cData(1, 1) = crg.Value
End If
' Store the unique values from the criteria array in the 'keys'
' of a dictionary ('dict').
' The 'items' are irrelevant but will hold 'Empty'.
' Error values and blanks are excluded.
' Define the dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'A = a'
Dim cKey As Variant ' Current Value in the Criteria Array
Dim r As Long ' Current Row in the Criteria Array
' Store the unique valus in the dictionary.
For r = 1 To rCount
cKey = cData(r, 1) ' retrieve the current value
If Not IsError(cKey) Then ' exclude error values
If Len(CStr(cKey)) > 0 Then ' exclude blanks
' Check if the current value exists in the dictionary.
' This is not necessary but will ensure that the first occuring
' string's case is used. Otherwise, the last would be used.
If Not dict.Exists(cKey) Then
dict(cKey) = Empty ' store the unique value in a 'key'
End If
End If
End If
Next r
' Populate the list box with the sorted unique values
' from the dictionary and inform.
With ClientInput
' Validate the dictionary.
If dict.Count = 0 Then
.Clear ' or not?
Application.ScreenUpdating = True
MsgBox "No valid data.", vbExclamation, ProcTitle
Exit Sub
End If
.List = dict.Keys ' 'dict.Keys' is a zero-based (1D) array
Application.ScreenUpdating = True
MsgBox "Client input populated.", vbInformation, ProcTitle
End With
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/508285.html
標籤：vba