Exel VBA: Run-Time Error 13 Тип Несовпадение

Question

У меня есть следующий список на Лист1:

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 

На Лист2, я хотел бы следующий вывод в колонке B, когда я вхожу «Адрес1» в ячейке B4

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 код (модуль "Лист2")

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 код (Обычный модуль)

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 
  

надеюсь, что это может помочь вам

дайте мне знать, если вы