[英]filter unique values and sort A to Z Excel VBA
I have been using below code to Filter the Unique values from Sheet1
and paste them into Sheet2
my code is working fine.我一直在使用下面的代码来过滤
Sheet1
的唯一值并将它们粘贴到Sheet2
我的代码工作正常。 But it has one issue that is when i remove any value from Sheet1.Range(C4:C) cell it gives empty cell in Sheet2
like in below image.但它有一个问题,即当我从 Sheet1.Range(C4:C) 单元格中删除任何值时,它会在
Sheet2
中给出空单元格,如下图所示。
I want that if i remove any cell value from Sheet1 range then Code should automatically adjust it.我希望如果我从 Sheet1 范围中删除任何单元格值,那么代码应该自动调整它。 there should not be any empty cell in Sheet2 Range.
Sheet2 Range 中不应有任何空单元格。
I also wants to add sort function in the code so unique values will be popup with sorting A to Z in sheet2.我还想在代码中添加排序 function 以便在 sheet2 中排序 A 到 Z 时弹出唯一值。
I tried at my end to do both things but cannot do.我最终尝试做这两件事,但做不到。 Your help in this regard will be highly appreciated.
您在这方面的帮助将不胜感激。
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
This is the code I've used:这是我使用的代码:
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
You'll need also this UDF to sort arrays:您还需要这个 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
My source sheet (your Sheet1) is:我的源表(您的 Sheet1)是:
And when executing code, in my destiny sheet (your sheet2) I get:在执行代码时,在我的命运表(您的 sheet2)中,我得到:
All data sorted and no blanks:)所有数据都已排序,没有空格:)
Hope you can adapt this to your needs.希望您可以根据自己的需要进行调整。
about function to sort arrays, all credits go to author: https://stackoverflow.com/a/152325/9199828 about function to sort arrays, all credits go to author: https://stackoverflow.com/a/152325/9199828
If you have O365, you can use a worksheet formula:如果您有 O365,则可以使用工作表公式:
=UNIQUE(SORT(FILTER(Sheet10!$C$4:$C$10000,Sheet10!$C$4:$C$10000<>"")))
Replace Sheet1
with the actual name of your worksheet将
Sheet1
替换为工作表的实际名称
Another VBA method, using the ArrayList object:另一种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' and an Array List
as a sorting option.Dictionary
for 'unique' 和Array List
作为排序选项。C
from cell C4
of Sheet1
, the unique values appear sorted in column C
from cell C4
of Sheet2
.Sheet1
的单元格C4
更改列C
中的值时,唯一值将显示在来自Sheet2
的单元格C4
的C
列中。 Standard Module (eg Module1
)标准模块(例如
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
Sheet Module ( Sheet1
)工作表模块 (
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.