Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
'///////////////////////////////////////////////////////
#If Win64 Then
Private gTimerID As LongPtr, gTimerID2 As LongPtr
#Else
Private gTimerID As Long, gTimerID2 As Long
#End If
'///////////////////////////////////////////////////////
Private VLOOKUP_OArgs(), VLOOKUP_OIndex As Integer
Function S_VLOOKUP(ByVal Look_value As Variant, _
ByVal table_Array As Excel.Range, _
ByVal table_index As Excel.Range, _
Optional ByVal range_look As Boolean, _
Optional ByVal CopyComment As Boolean, _
Optional ByVal Formatting As Boolean, _
Optional ByVal GetFormula As Boolean) As Variant
On Error Resume Next
KillTimer 0&, gTimerID: gTimerID = 0
'-----------------------------------------------
Set table_Array = table_Array.Parent.Range(table_Array.Address)
Set table_index = table_index.Parent.Range(table_index.Address)(1, 1)
Dim R As Excel.Range, Args
Dim I As Long
I = Application.WorksheetFunction.Match(Look_value, table_Array, range_look)
If I > 0 Then
Set R = table_index(I, 1)
If GetFormula Then S_VLOOKUP = R.Formula Else S_VLOOKUP = R.Value
Else
S_VLOOKUP = "#N/A"
End If
'-----------------------------------------------
Dim UB As Integer, K As Integer
'-----------------------------------------------
UB = UBound(VLOOKUP_OArgs, 2): K = UB
K = K + 1
ReDim Preserve VLOOKUP_OArgs(1 To K)
VLOOKUP_OArgs(K) = Array(Application.Caller, R, CopyComment, Formatting)
Work:
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_VLOOKUP_callback)
End Function
'///////////////////////////////////////////////////////
Private Sub S_VLOOKUP_callback()
On Error Resume Next
Call KillTimer(0&, gTimerID): gTimerID = 0
Call KillTimer(0&, gTimerID2): gTimerID2 = 0
On Error GoTo 0
'----------------------------------
Dim UB As Integer
UB = UBound(VLOOKUP_OArgs)
If UB > 0 Then
VLOOKUP_OIndex = VLOOKUP_OIndex + 1
'-------------------------------------------
Dim Args
Args = VLOOKUP_OArgs(VLOOKUP_OIndex)
If Not Args(1) Is Nothing Then
If Args(2) Then CopyComment Args(1), Args(0)
If Args(3) Then CopyFormat Args(1), Args(0)
Else
If Args(2) Then Args(0).ClearComments
If Args(3) Then Call ClearFormat(Args(0))
End If
'-------------------------------------------
If VLOOKUP_OIndex >= UB Then
Erase VLOOKUP_OArgs: VLOOKUP_OIndex = 0
Else
gTimerID = SetTimer(0&, 0&, 1, AddressOf S_VLOOKUP_callback2)
End If
End If
End Sub
Private Sub S_VLOOKUP_callback2()
S_VLOOKUP_callback
End Sub
'///////////////////////////////////////////////////////
Sub CopyComment(ByVal frRange As Range, ByVal toRange As Range)
On Error Resume Next
If frRange Is Nothing Or toRange Is Nothing Then Exit Sub
Set frRange = frRange.Parent.Range(frRange.Address)(1, 1)
Set toRange = toRange.Parent.Range(toRange.Address)(1, 1)
If frRange.Comment Is Nothing Then Exit Sub
toRange.ClearComments
With toRange
With .AddComment(frRange.Comment.Text)
.Shape.Width = frRange.Comment.Shape.Width
.Shape.Height = frRange.Comment.Shape.Height
End With
End With
End Sub
Sub CopyFormat(ByVal frRange As Range, ByVal toRange As Range)
On Error Resume Next
If frRange Is Nothing Or toRange Is Nothing Then Exit Sub
Set frRange = frRange.Parent.Range(frRange.Address)(1, 1)
Set toRange = toRange.Parent.Range(toRange.Address)(1, 1)
With toRange
With .Interior
.Color = frRange.Interior.Color
.TintAndShade = frRange.Interior.TintAndShade
'.ThemeColor = frRange.Interior.ThemeColor
.PatternTintAndShade = frRange.Interior.PatternTintAndShade
'.PatternThemeColor = frRange.Interior.PatternThemeColor
.PatternColorIndex = frRange.Interior.PatternColorIndex
End With
With .Font
.Color = frRange.Font.Color
.Name = frRange.Font.Name
.Bold = frRange.Font.Bold
.Italic = frRange.Font.Italic
.Size = frRange.Font.Size
.Strikethrough = frRange.Font.Strikethrough
.Subscript = frRange.Font.Subscript
.Superscript = frRange.Font.Superscript
.ThemeFont = frRange.Font.ThemeFont
.TintAndShade = frRange.Font.TintAndShade
.Underline = frRange.Font.Underline
End With
Dim index As Long
index = xlDiagonalDown: GoSub Borders
index = xlDiagonalUp: GoSub Borders
index = xlInsideHorizontal: GoSub Borders
index = xlInsideVertical: GoSub Borders
index = xlEdgeBottom: GoSub Borders
index = xlEdgeRight: GoSub Borders
index = xlEdgeLeft: GoSub Borders
index = xlEdgeTop: GoSub Borders
End With
Exit Sub
Borders:
With toRange.Borders(index)
.Weight = frRange.Borders(index).Weight
.Color = frRange.Borders(index).Color
.LineStyle = frRange.Borders(index).LineStyle
.ThemeColor = frRange.Borders(index).ThemeColor
.TintAndShade = frRange.Borders(index).TintAndShade
End With
Return
End Sub
Sub ClearFormat(ByVal oRange As Range)
On Error Resume Next
With oRange
.Font.Color = 0
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
End Sub
