我的 VBA Selection.SpecialCells(xlCellTypeConstants, 1) cell.Value = cell.Text 中的错误

Question

Hello I have an excel program that filters my table when I copy/paste my references in column J. However depending on where I copied the references it doesn't work.

VBA tells me this: Selection.SpecialCells(xlCellTypeConstants, 2 )

I do not understand why.

Here is my program:

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

Can anyone help me?

Answer 1

Filter on a 'Bunch of Values'

• Adjust the values in the constants section.

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