Exel VBA：运行时错误13types不匹配

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中input“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 

Sub FilterAddress Code （常规模块）

 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 

我发现，如果我input一个地址，它会给我所需的输出。 如果我编辑B4将地址更改为另一个，它也可以。 但是，当我删除单元格B4，我收到一条消息，说：“运行时错误13types不匹配。

当我debugging时，它把我带到了线上

  Call FilterAddress(Target.Value) 

如何更改代码，以便单元格B4被删除时，不采取任何操作，并出现一条消息，要求用户input地址？

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，我只是得到“您input的约会＃是不正确或不存在，请再试一次”消息。 这很好。

也许重构你的代码可以帮助你debugging它

比如你可以

• 按需排列数组，如下所示：

   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 

希望这可以帮助你

让我知道你是否愿意