Você não pode fazer script diretamente do complemento Fuzzy Lookup , mas consegui contornar a maioria dos erros e problemas com ele.
O código a seguir irá "bloquear" o local de saída para a tabela especificada, independentemente da posição da célula ativa usando o
Workbook_SheetChange e Workbook_SheetSelectionChange events:
'============================================================================================
' Module : ThisWorkbook
' Version : 1.0
' Part : 1 of 1
' References : N/A
' Source : https://superuser.com/a/1283003/763880
'============================================================================================
Option Explicit
Private Const s_FuzzyLookupResultsTable As String = "MatchingTable"
Private Const RESTORE_SELECTION As Boolean = True
Private Sub Workbook_SheetChange _
( _
ByVal TheWorksheet As Object, _
ByVal Target As Range _
)
Dim Ä As Excel.Application: Set Ä = Excel.Application
Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction
Const l_FuzzyLookup_AddIn_Undo_Sheet As String = "FuzzyLookup_AddIn_Undo_Sheet"
Const s_InCell_Error_Message As String = "SAVE, CLOSE & REOPEN if pressing GO again doesn't fix it"
Static swkstActiveFuzzyLookupSheet As Worksheet
Static sstrOriginalSelection As String
Select Case True
Case TheWorksheet.Name <> l_FuzzyLookup_AddIn_Undo_Sheet And swkstActiveFuzzyLookupSheet Is Nothing:
Exit Sub
Case TheWorksheet.Name = l_FuzzyLookup_AddIn_Undo_Sheet And swkstActiveFuzzyLookupSheet Is Nothing:
'TODO If missing table
Set swkstActiveFuzzyLookupSheet = ActiveSheet
sstrOriginalSelection = Selection.Address
Case TheWorksheet.Name = l_FuzzyLookup_AddIn_Undo_Sheet And Not swkstActiveFuzzyLookupSheet Is Nothing:
With swkstActiveFuzzyLookupSheet.ListObjects(s_FuzzyLookupResultsTable)
Ä.EnableEvents = False
' This is a Fuzzy Lookup bug work-around to show an in-cell error if the output doesn't update
If .ListColumns.Count > 1 Then
Dim strHeaderRowRange As String: strHeaderRowRange = .HeaderRowRange.Address
Dim varHeaders() As Variant: varHeaders = ƒ.Transpose(ƒ.Transpose(.HeaderRowRange.Value2))
With Range(.ListColumns(2).DataBodyRange, .ListColumns(.ListColumns.Count).DataBodyRange)
Dim strDeletedRange As String: strDeletedRange = .Address
.Delete
End With
Range(strDeletedRange).Insert Shift:=xlToRight
Range(strDeletedRange).Value2 = s_InCell_Error_Message
Range(strHeaderRowRange).Value2 = varHeaders
End If
' This is the magic line that forces the output back into the table
.HeaderRowRange.Cells(1).Select
Ä.EnableEvents = True
End With
Case TheWorksheet.Name = swkstActiveFuzzyLookupSheet.Name:
With swkstActiveFuzzyLookupSheet.ListObjects(s_FuzzyLookupResultsTable).Range
If Target.Cells(Target.Cells.Count).Address = .Cells(.Cells.Count).Address Then
' <optional>
' Only restore the selection if set to do so and the selection is not the first header cell
If RESTORE_SELECTION _
And sstrOriginalSelection <> .Cells(1).Address _
Then
Ä.EnableEvents = False
Range(sstrOriginalSelection).Select
Ä.EnableEvents = True
' Unfortunately the above Select doesn't stick. The Add-in trys to change the selection another 1 or 2 times.
' The following hack is required so that the Workbook_SheetSelectionChange handler can revert these attempts.
' Note that if the original selection contains the first header cell, only 1 attempt is made. Otherwise it makes 2 attempts.
RevertSelection _
RevertTo:=Selection, _
NumberOfTimes:=IIf(Intersect(Selection, .Cells(1)) Is Nothing, 2, 1)
End If
' </optional>
sstrOriginalSelection = vbNullString
Set swkstActiveFuzzyLookupSheet = Nothing
End If
End With
Case Else:
Exit Sub
'End Cases
End Select
End Sub
' The following code is only needed if the RESTORE_SELECTION option is required.
' If the code is removed, the optional code in the Workbook_SheetChange handler above also needs to be removed.
Private Sub RevertSelectionIfRequired()
RevertSelection
End Sub
Private Sub RevertSelection _
( _
Optional ByRef RevertTo As Range, _
Optional ByRef NumberOfTimes As Long _
)
Static srngRevertTo As Range
Static slngRevertCount As Long
Select Case True
Case Not RevertTo Is Nothing:
Set srngRevertTo = RevertTo
slngRevertCount = NumberOfTimes
Case Not srngRevertTo Is Nothing:
With Application
.EnableEvents = False
srngRevertTo.Select
.EnableEvents = True
End With
slngRevertCount = slngRevertCount - 1
If slngRevertCount = 0 Then Set srngRevertTo = Nothing
Case Else:
Exit Sub
'End Cases
End Select
End Sub
Private Sub Workbook_SheetSelectionChange _
( _
ByVal TheWorksheet As Object, _
ByVal Target As Range _
)
RevertSelectionIfRequired
End Sub