VBA选择错误.SpecialCells(xlCellTypeConstants，1)单元格.值=单元格.文本

Question

你好，我有一个excel程序，当我在J列中复制/粘贴引用时，它会过滤我的表。但是，根据我复制引用的位置，它不起作用。

VBA告诉我：选择。SpecialCells(xlCellTypeConstants，2(

我不明白为什么。

这是我的程序：

Sub DoMyFilter()
Columns("A:J").Select
Selection.NumberFormat = "@"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cell As Range
For Each cell In _
Selection.SpecialCells(xlCellTypeConstants, 1)
cell.Value = cell.Text
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Dim vCrit As Variant
Dim aCrit As Variant

vCrit = Range("J2:J100000").Value
aCrit = Application.Transpose(vCrit)

ActiveSheet.Range("$A$1:$H$7634").AutoFilter Field:=1, Criteria1:=aCrit, Operator:=xlFilterValues

Range("J:J").ClearContents

End Sub

有人能帮我吗？

Answer 1

对"Bunch of Values"进行筛选

• 调整常量部分中的值

Option Explicit
Sub DoMyFilter()

Const dCols As String = "A:H" ' Destination Columns Range
Const dFirst As Long = 1 ' Destination First Row
Const dField As Long = 1 ' Destination Criteria Field (Column)

Const cCol As String = "J" ' Criteria Column
Const cFirst As Long = 2 ' Criteria First Row

' Turn off possibly applied AutoFilter.
Dim ws As Worksheet: Set ws = ActiveSheet
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If

' Define Criteria Column Range.
Dim crg As Range ' Criteria Last Cell
With ws.Columns(cCol)
Dim cCell As Range
Set cCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If cCell Is Nothing Then Exit Sub ' Validate.
If cCell.Row < cFirst Then Exit Sub ' Validate.
Set crg = .Resize(cCell.Row - cFirst + 1).Offset(cFirst - 1)
End With
'Debug.Print crg.Address

' Write values from Criteria Column Range to 2D one-based Data Array.
Dim crCount As Long: crCount = crg.Rows.Count
Dim Data As Variant
If crCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data = crg.Value
Else
Data = crg.Value
End If

' Write unique values, except error values and blanks, from Data Array
' to Unique Dictionary and to 1D zero-based Criteria Array.
' The dictionary is used to remove duplicates.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim Criteria() As String: ReDim Criteria(0 To crCount - 1)
Dim n As Long: n = -1 ' Criteria Array Elements Counter
Dim Key As Variant ' Value of Current Element in Data Array
Dim r As Long ' Data Array Rows Counter
For r = 1 To crCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
Key = CStr(Key)
If Not dict.Exists(Key) Then
n = n + 1
Criteria(n) = Key
dict(Key) = Empty
End If
End If
End If
Next r
Set dict = Nothing
Erase Data
If n = -1 Then Exit Sub ' Validate.
ReDim Preserve Criteria(0 To n)

' Define Destination Range.
Dim drg As Range
With ws.Columns(dCols)
Dim dCell As Range ' Destination Last Cell
Set dCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If dCell Is Nothing Then Exit Sub ' Validate.
If dCell.Row < dFirst Then Exit Sub ' Validate.
Set drg = .Resize(dCell.Row - dFirst + 1)
End With
'Debug.Print drg.Address

' Turn off application settings.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

' Apply AutoFilter.
drg.AutoFilter Field:=dField, Criteria1:=Criteria, Operator:=xlFilterValues

' Clear contents of Criteria Column.
'ws.columns(cCol).ClearContents ' ???

' Turn on application settings.
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub