我在Sheet1上有以下列表：
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
在Sheet2上，当我在单元格B4中输入“Address1”时，我想在B列中输出以下内容
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
Worksheet_Change Code （“Sheet2”模块）
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
当我在Sheet2上的单元格B4中输入“Address1”时，收到以下错误：
Runtime error '9':
Subscript out of range
但是，如果我保存文件并填充B4并关闭它，然后重新打开文件，当我编辑单元格内容以说明Address1或Address2时，我能够使宏正常工作。
导致“下标超出范围”消息的原因是什么，以及如何更改代码以避免它？我是否需要更新 Worksheet_Change代码中的代码？
我还注意到，如果我在Sheet2上删除了单元格B4的内容，我会收到以下错误：
Run-time error'1004':
No cells were found.
这两个错误是否相关？
答案 0 :(得分：1)
最高＆＃39; j＆＃39;不受工作表上行数的限制 - 它由可以从这些行中拆分的元素数量限制。在您的代码执行之前无法确定需要标注尺寸ServiceArr的尺寸。这意味着根据数据，您将在本节中获得间歇性的下标错误：
ReDim ServiceArr(1 To LastRow) '<-- This is only a guess. j = 1 For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible) Service = Split(cell.Value, ",") For i = LBound(Service) To UBound(Service) Service(i) = Trim(Service(i)) If Not Dict.exists(Service(i)) Then Dict.Add Service(i), Service(i) ServiceArr(j) = Service(i) '<--Subscript error here if unique elements > LastRow j = j + 1 End If Next i Next cell
解决方案非常简单 - 完全摆脱ServiceArr。它始终与Dict.Keys和Dict.Values完全相同，因为您基本上保留了第三个相同数据的相同副本：
Dict.Add Service(i), Service(i) ServiceArr(j) = Service(i)
这与您的代码几乎完全相同，除了它为您提供基于0的数组而不是基于1的数组：
For Each cell In .Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
Service = Split(cell.Value, ",")
For i = LBound(Service) To UBound(Service)
Service(i) = Trim(Service(i))
If Not Dict.exists(Service(i)) Then
Dict.Add Service(i), Empty
End If
Next i
Next cell
ServiceArr = Dict.Keys
'...
'Adjust this to 0 based.
For i = LBound(ServiceArr) To UBound(ServiceArr)
请参阅@YowE3K's comment了解您收到其他错误的原因。
答案 1 :(得分：0)
嗯，只是疯狂地猜测，但你可以尝试以下方法：
选项1
代替：
For i = 1 To UBound(ServiceArr) - 1
For j = i + 1 To UBound(ServiceArr)
写：
For i = 0 To UBound(ServiceArr) - 1
For j = i + 1 To UBound(ServiceArr)
选项2
代替：
j = 1 ' init array counter
写：
j = 0 ' init array counter
如果无效，请提供有关错误行的信息。例如。一旦看到错误消息，请按debug并查看哪条线为黄色。