![](/img/trans.png)
[英]VBA Excel Autofilter highlight the unique values and sort them by color
[英]filter unique values and sort A to Z Excel VBA
我一直在使用下面的代码来过滤Sheet1
的唯一值并将它们粘贴到Sheet2
我的代码工作正常。 但它有一个问题,即当我从 Sheet1.Range(C4:C) 单元格中删除任何值时,它会在Sheet2
中给出空单元格,如下图所示。
我希望如果我从 Sheet1 范围中删除任何单元格值,那么代码应该自动调整它。 Sheet2 Range 中不应有任何空单元格。
我还想在代码中添加排序 function 以便在 sheet2 中排序 A 到 Z 时弹出唯一值。
我最终尝试做这两件事,但做不到。 您在这方面的帮助将不胜感激。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Sheet1.Range("C4:C" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Sheet2.Range("C4").Resize(d.Count) = Application.Transpose(d.keys)
End Sub
这是我使用的代码:
Sub test()
Dim WkSource As Worksheet
Dim WkDestiny As Worksheet
Dim MiMatriz() As Variant
Dim LR As Long
Dim i As Long
Dim ZZ As Long
Set WkSource = ThisWorkbook.Worksheets("source") 'Replace SOURCE with name of your Sheet1
Set WkDestiny = ThisWorkbook.Worksheets("destiny") 'Replace DESTINY with name of your sheet2
With WkSource
LR = .Cells(.Rows.Count, 3).End(xlUp).Row 'Last non empty cell in colum C
ReDim MiMatriz(1 To LR - 4 + 1) 'we do LR-4 because your data starts at row 4, and we add 1
ZZ = 1
For i = 4 To LR Step 1
MiMatriz(ZZ) = .Range("C" & i).Value
ZZ = ZZ + 1
Next i
End With
'sort
Call QuickSort(MiMatriz, 1, UBound(MiMatriz))
'paste
'we paste array, excluding blanks
ZZ = 4 'starting at row 4
For i = 1 To UBound(MiMatriz) Step 1
If MiMatriz(i) <> "" Then
WkDestiny.Range("C" & ZZ).Value = MiMatriz(i)
ZZ = ZZ + 1
End If
Next i
'Remove duplicates
WkDestiny.Range("C4:C" & ZZ - 1).RemoveDuplicates Columns:=1, Header:=xlNo
Erase MiMatriz
Set WkSource = Nothing
Set WkDestiny = Nothing
End Sub
您还需要这个 UDF 来对 arrays 进行排序:
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
我的源表(您的 Sheet1)是:
在执行代码时,在我的命运表(您的 sheet2)中,我得到:
所有数据都已排序,没有空格:)
希望您可以根据自己的需要进行调整。
about function to sort arrays, all credits go to author: https://stackoverflow.com/a/152325/9199828
如果您有 O365,则可以使用工作表公式:
=UNIQUE(SORT(FILTER(Sheet10!$C$4:$C$10000,Sheet10!$C$4:$C$10000<>"")))
将Sheet1
替换为工作表的实际名称
另一种VBA方法,使用ArrayList object:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rg As Range, c As Range
Dim AL As Object, vData As Variant, v As Variant, I As Long
Dim ws2 As Worksheet
Set ws2 = Worksheets("sheet11") 'destination for paste operation
Set rg = Range(Cells(4, 3), Cells(Rows.Count, 3).End(xlUp))
If Not Intersect(rg, Target) Is Nothing Then
Set AL = CreateObject("System.Collections.ArrayList")
vData = rg 'fastest to work from vba array
For I = 1 To UBound(vData)
v = vData(I, 1)
If Not v = "" And Not AL.contains(v) Then
AL.Add v
End If
Next I
AL.Sort
'If might have more than 65,535 items, cannot use Transpose
Application.ScreenUpdating = False
ws2.Range("c4").Resize(Rows.Count - 4).ClearContents
With ws2.Range("c4").Resize(AL.Count, 1)
.Value = WorksheetFunction.Transpose(AL.toarray)
.Range(.Cells(.Rows.Count, 1), .Cells(.Rows.Count, 1).End(xlUp)).ClearContents
End With
End If
End Sub
Dictionary
for 'unique' 和Array List
作为排序选项。Sheet1
的单元格C4
更改列C
中的值时,唯一值将显示在来自Sheet2
的单元格C4
的C
列中。 标准模块(例如Module1
)
Option Explicit
Sub copySortedUniqueColumn( _
SourceRange As Range, _
DestinationCell As Range, _
Optional ByVal doSort As Boolean = True)
Dim Data As Variant
If SourceRange.Rows.Count > 1 Or SourceRange.Columns.Count > 1 Then
Data = SourceRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = SourceRange.Value
End If
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim Key As Variant
Dim i As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
Key = Data(i, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
If Not .Exists(Key) Then
.Item(Key) = Empty
arl.Add Key
End If
End If
End If
Next i
If .Count = 0 Then Exit Sub
End With
If doSort Then
arl.Sort
End If
ReDim Data(1 To arl.Count, 1 To 1)
i = 0
For Each Key In arl
i = i + 1
Data(i, 1) = Key
Next Key
With DestinationCell
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(i).Value = Data
End With
End Sub
Function defineColumnRange( _
FirstCellRange As Range) _
As Range
On Error GoTo clearError
If FirstCellRange Is Nothing Then GoTo ProcExit
With FirstCellRange
Dim cel As Range: Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If cel Is Nothing Then GoTo ProcExit
Set defineColumnRange = .Resize(cel.Row - .Row + 1)
End With
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function
工作表模块 ( Sheet1
)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const srcFirst As String = "C4"
Const dstFirst As String = "C4"
Dim srg As Range: Set srg = defineColumnRange(Range(srcFirst))
If srg Is Nothing Then
With Sheet2.Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
End With
Exit Sub
End If
Dim rg As Range: Set rg = Intersect(srg, Target)
If rg Is Nothing Then Exit Sub
Dim dCel As Range: Set dCel = Sheet2.Range(dstFirst)
On Error GoTo clearError
Application.EnableEvents = False
copySortedUniqueColumn srg, dCel
SafeExit:
Application.EnableEvents = True
Exit Sub
clearError:
Resume SafeExit
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.