Exel VBA：運行時錯誤13類型不匹配

Question

我在Sheet1上有以下列表：

   COLUMN A    COLUMNB             COLUMN C 
1  ADDRESS     Services(s) USED    VEHICLE(S) USED
2  Address1    Service1, Service3  Vehicle1, Vehicle3, Vehicle4  
3  Address2    Service1, Service4  Vehicle1, Vehicle3, Vehicle4
4  Address3    Service2, Service5  Vehicle1, Vehicle2, Vehicle5
5  Address4    Service2, Service3  Vehicle1, Vehicle6 
6  Address1    Service5, Service6  Vehicle2, Vehicle5, Vehicle6 
7  Address2    Service2, Service3  Vehicle2, Vehicle3
8  Address4    Service4, Service6  Vehicle1, Vehicle2, Vehicle3, Vehicle4, Vehicle5, Vehicle6   

在Sheet2上，當我在單元格B4中輸入“ Address1”時，我希望B列中的以下輸出

   COLUMN A    COLUMN B            


4              Address1                                                                 

12             Service1
13             Service3
14             Service5
15             Service6
16
17

50             Vehicle1
51             Vehicle2
52             Vehicle3
53             Vehicle4
54             Vehicle5
56             Vehicle6

以下是我正在使用的代碼：

Worksheet_Change代碼 （“ Sheet2”模塊）

Private Sub Worksheet_Change(ByVal Target As Range)

' call Function only if modifed cell is in Column "B"
If Not IsError(Application.Match(Range("B4"), Worksheets("Google Data").Range("E1:E" & LastRow(Worksheets("Google Data"))), 0)) Then
    If Not Intersect(Target, Range("B4")) Is Nothing Then
        If (Target.Value <> "") Then
            Application.EnableEvents = False
            Call FilterAddress(Target.Value)
        Else
            On Error Resume Next
            MsgBox Target.Address & "Cell can't be blank, Input a value first."
            Err.Clear
            Exit Sub
        End If
    End If
Else
On Error Resume Next
    MsgBox "The Appointment # you entered is incorrect or does not exist. Please try again."
    Err.Clear
    Exit Sub
End If

Application.EnableEvents = True

End Sub

子過濾器地址代碼 （常規模塊）

Option Explicit

Sub FilterAddress(FilterVal As String)


Dim LastRow As Long
Dim FilterRng As Range, cell As Range
Dim Dict As Object
'Dim ID
Dim Vehicle As Variant
Dim VehicleArr As Variant
Dim i As Long, j As Long
Dim Service As Variant
Dim ServiceArr As Variant
Dim x As Long, y As Long
Dim My_Range As Range

With Sheets("Sheet1")
    ' find last row with data in column "A" (Adress)
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    Set FilterRng = .Range("A1:C" & LastRow)

    .Range("A1").AutoFilter
    ' AutoFilter "Sheet1" according to value in "Sheet2" in Column B
    FilterRng.AutoFilter Field:=1, Criteria1:=FilterVal

    Set Dict = CreateObject("Scripting.Dictionary")

    ' create an array with size up to number of rows >> will resize it later
    ReDim ServiceArr(1 To LastRow)
    j = 1 ' init array counter

    For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
        ' read values from cell to array using the Split function
        Service = Split(cell.Value, ",")

        For i = LBound(Service) To UBound(Service)
            Service(i) = Trim(Service(i)) ' remove extra spaces from string

            If Not Dict.exists(Service(i)) Then
                Dict.Add Service(i), Service(i)

                ' save Service Name to array >> will use it later for "Bubble-sort" and paste in "Sheet2"
                ServiceArr(j) = Service(i)
                j = j + 1 ' increment ServiceArr counter
            End If
        Next i

    Next cell
    ' resize array up to number of actual Service
    ReDim Preserve ServiceArr(1 To j - 1)

End With

Dim ServiceTmp As Variant
' Bubble-sort Service Array >> sorts the Service array from smallest to largest
For i = 1 To UBound(ServiceArr) - 1
    For j = i + 1 To UBound(ServiceArr)
        If ServiceArr(j) < ServiceArr(i) Then
            ServiceTmp = ServiceArr(j)
            ServiceArr(j) = ServiceArr(i)
            ServiceArr(i) = ServiceTmp
        End If
    Next j
Next i

' now the "fun" part >> paste to "Sheet2"
With Sheets("Sheet2")
    .Range("A1").Value = "ADDRESS"
    .Range("B4").Value = FilterVal
    .Range("C1").Value = "VEHICLE(S) USED"

    ' clear contents from previous run

    .Range("B12:B17").ClearContents
    .Range("B12:B" & UBound(ServiceArr) + 11) = WorksheetFunction.Transpose(ServiceArr)

End With

FilterRng.Parent.AutoFilterMode = False

With Sheets("Sheet1")
    ' find last row with data in column "A" (Adress)
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    Set FilterRng = .Range("A1:C" & LastRow)

    .Range("A1").AutoFilter
    ' AutoFilter "Sheet1" according to value in "Sheet2" in Column B
    FilterRng.AutoFilter Field:=1, Criteria1:=FilterVal

    Set Dict = CreateObject("Scripting.Dictionary")

    ' create an array with size up to number of rows >> will resize it later
    ReDim VehicleArr(1 To LastRow)
    y = 1 ' init array counter

    For Each cell In .Range("C2:C" & LastRow).SpecialCells(xlCellTypeVisible)
        ' read values from cell to array using the Split function
        Vehicle = Split(cell.Value, ",")

        For x = LBound(Vehicle) To UBound(Vehicle)
            Vehicle(x) = Trim(Vehicle(x)) ' remove extra spaces from string

            If Not Dict.exists(Vehicle(x)) Then
                Dict.Add Vehicle(x), Vehicle(x)

                ' save Vehicle Name to array >> will use it later for "Bubble-sort" and paste in "Sheet2"
                VehicleArr(y) = Vehicle(x)
                y = y + 1 ' increment VehicleArr counter
            End If
        Next x

    Next cell
    ' resize array up to number of actual Vehicle
    ReDim Preserve VehicleArr(1 To y - 1)

End With

Dim VehicleTmp As Variant
' Bubble-sort Vehicle Array >> sorts the Vehicle array from smallest to largest
For x = 1 To UBound(VehicleArr) - 1
    For y = x + 1 To UBound(VehicleArr)
        If VehicleArr(y) < VehicleArr(x) Then
            VehicleTmp = VehicleArr(y)
            VehicleArr(y) = VehicleArr(x)
            VehicleArr(x) = VehicleTmp
        End If
    Next y
Next x

' now the "fun" part >> paste to "Sheet2"
With Sheets("Sheet2")
    .Range("A1").Value = "ADDRESS"
    .Range("B4").Value = FilterVal
    .Range("C1").Value = "VEHICLE(S) USED"

    ' clear contents from previous run

    .Range("B50:B55").ClearContents
    .Range("B50:B" & UBound(VehicleArr) + 49) = WorksheetFunction.Transpose(VehicleArr)

End With

FilterRng.Parent.AutoFilterMode = False
End Sub

我發現，如果輸入一個地址，它將給我所需的輸出。 如果我編輯B4將地址更改為另一個，它也可以使用。 但是，當我刪除單元格B4時，我收到一條消息，指出“運行時錯誤13鍵入不匹配。

當我進行調試時，它使我進入了生產線

 Call FilterAddress(Target.Value)

如何更改代碼，以便在刪除單元格B4時不采取任何措施，並出現一條消息，要求用戶輸入地址？

Answer 1

像這樣包含一些額外的B4值檢查的東西就足夠了。

If Not Intersect(Target, Range("B4")) Is Nothing Then
        If (Target.Value <> "") Then
            Application.EnableEvents = False
            Call FilterAddress(Target.Value)
        Else
            MsgBox Target.Address & " can't be blank, Input a value first."
        End If
    End If

---

以防萬一您想以詳細的方式做事....

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strErr As String

    If Not Intersect(Target, Range("B4")) Is Nothing Then
        If IsTargetValid(Target, strErr) Then
            Application.EnableEvents = False
            Call FilterAddress(Target.Value)
        Else
            MsgBox strErr
        End If
    End If
End Sub

Public Function IsTargetValid(rng As Range, ByRef strErr As String) As Boolean

    Dim bResult As Boolean

    bResult = True
    If bResult And IsError(rng) Then
        bResult = False
        strErr = rng.Address & " contains error value."
    End If

    If bResult And rng.Cells.Count <> 1 Then
        bResult = False
        strErr = rng.Address & " contains invalid number of cells."
    End If

    If bResult And rng <> "" Then
        bResult = False
        strErr = rng.Address & " can't be blank, input a value first."
    End If

    '// Keep adding any other condition you want to check.

    IsTargetValid = bResult

End Function

Answer 2

實際上，您的Worksheet_Change()事件處理程序對我有用：如果刪除單元格B4，我只會收到“您輸入的約會編號不正確或不存在。請重試”消息。 沒關系

也許重構代碼可以幫助您調試它

例如你可以

• 需求數組對特定Sub的排序，如下所示：

   Sub OrderArray(arrayToOrder As Variant) Dim ServiceTmp As Variant Dim iRow As Long, iRow2 As Long ' Bubble-sort Service Array >> sorts the passed array from smallest to largest For iRow = LBound(arrayToOrder) To UBound(arrayToOrder) - 1 For iRow2 = iRow + 1 To UBound(arrayToOrder) If arrayToOrder(iRow2) < arrayToOrder(iRow) Then ServiceTmp = arrayToOrder(iRow2) arrayToOrder(iRow2) = arrayToOrder(iRow) arrayToOrder(iRow) = ServiceTmp End If Next Next End Sub 

• 要求獲得功能范圍之外的唯一值和有序值，如下所示

   Function GetOrderedUniqueValuesArrayFromRange(filteredRng As Range) As Variant Dim cell As Range Dim arr As Variant Dim iArr As Variant With CreateObject("Scripting.Dictionary") '<--| create a late binded 'Dictionary' object "on the fly" - no need for adding any library references to the project For Each cell In filteredRng ' read values from cell to array using the Split function arr = Split(cell.value, ",") For iArr = LBound(arr) To UBound(arr) arr(iArr) = Trim(arr(iArr)) ' remove extra spaces from string .item(arr(iArr)) = .item(arr(iArr)) + 1 Next Next cell GetOrderedUniqueValuesArrayFromRange = .Keys '<--| the dictionary keys is the wanted array, though not ordered OrderArray GetOrderedUniqueValuesArrayFromRange '<--| order it End With '<--| release the no more necessary 'Dictionary' object End Function 

• 那么您可以按如下所示折疊您的FilterAddress()子代碼：

   Sub FilterAddress(FilterVal As String) Dim FilterRng As Range Dim VehicleArr As Variant Dim ServiceArr As Variant With Sheets("Sheet1") '<--| reference your "data" sheet With .Range("C1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its columns A:C cells from row 1 down to column A last not empty one .AutoFilter '<--| remove any previuous filter .AutoFilter Field:=1, Criteria1:=FilterVal 'filter referenced range on its 1st column with 'FilterVal' value With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells skipping header row ServiceArr = GetOrderedUniqueValuesArrayFromRange(Intersect(.Cells, .Columns(2).EntireColumn)) '<--| fill ServiceArr with unique ordered values from 2nd column of referenced range VehicleArr = GetOrderedUniqueValuesArrayFromRange(Intersect(.Cells, .Columns(3).EntireColumn)) '<--| fill VehicleArr with unique ordered values from 3nd column of referenced range End With End With .AutoFilterMode = False '<--| show all rows back End With ' now the "fun" part >> paste to "Sheet2" With Sheets("Sheet2") .Range("A1").value = "ADDRESS" .Range("B4").value = FilterVal .Range("C1").value = "VEHICLE(S) USED" .Range("B12:B17").ClearContents ' clear service contents from previous run .Range("B12").Resize(UBound(ServiceArr) - LBound(ServiceArr) + 1) = WorksheetFunction.Transpose(ServiceArr) .Range("B50:B55").ClearContents ' clear vehicle contents from previous run .Range("B50").Resize(UBound(VehicleArr) - LBound(VehicleArr) + 1) = WorksheetFunction.Transpose(VehicleArr) End With End Sub 

希望這可以幫助您

讓我知道你是否願意