问下标超出范围(在Excel中从多个逗号分隔字符串宏中提取子字符串)

EN

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

   COLUMN A    COLUMN B            


4              Address1                                                                 

12             Service1
13             Service2
14             Service3
15             Service4
16             Service5
17             Service6

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

Private Sub Worksheet_Change(ByVal Target As Range)

' call Function only if modifed cell is in Column "B"
If Not Intersect(Target, Range("B4")) Is Nothing Then
    Application.EnableEvents = False

    Call FilterAddress(Target.Value)
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

Runtime error '9':

Subscript out of range

Run-time error'1004':

No cells were found.