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上，当我输入＆＃34;地址1和＃34;时，我想在B列中输出以下内容。在细胞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

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

工作表_更改代码（＆＃34; Sheet2＆＃34;模块）

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时，我收到一条消息，指出＆＃34;运行时错误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

实际上你的char *locale = setlocale(LC_ALL, "en_US.UTF-8"); FILE *in = fopen("test.txt", "r"); FILE *out = fopen("out.txt", "w"); wint_t c; while ((c = fgetwc(in)) != WEOF) { putwchar(c); fprintf(out, "%c ", c); } fclose(in); fclose(out);事件处理程序对我有效：如果我删除了单元格B4，我只是得到“你输入的约会＃不正确或不存在。请再试一次”信息。哪个没问题。

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

例如你可以

要求对特定Sub进行数组排序，如下所示：
```
Worksheet_Change()
```

要求将范围内的唯一和有序值从函数中获取，如下所示

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()
```

希望这可以帮到你

让我知道你是否会

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

2 个答案: