vba - VBA 用户定义函数中复制/粘贴特殊单元格格式

Question

我在 VBA 中有一个公式:- 执行VLOOKUP- 查找具有vlookup找到的值的单元格的地址- 问题:复制/粘贴特殊的原始单元格格式- vlookup的返回值

Function VLOOKUPnew(ValueToLook As Range, Interval As Range, ColIndex As Integer) As Variant

Dim fMatch, fVlookup

Dim ColMatchIndex
Dim CellOrigin, CellDestination

' ********************************************************************************
' LOOKUP:: Application.VLookup(ValueToLook, Interval, colIndex, False)
' MATCH:: Application.Match(ValueToLook, Range(Interval.Address()).Columns(1), 0)
' ********************************************************************************

' Indice da 1ª coluna do Intervalo
' **********************************************
ColMatchIndex = Interval.Columns(Interval.Columns.Count - 1).Column
' **********************************************

fMatch = Application.Match(ValueToLook, Range(Interval.Address()).Columns(1), 0)

' Obtem o endereço da célula que contem o valor do VLOOKUP
' **********************************************
CellOrigin = Interval.Cells(fMatch, Interval.Columns.Count).Address()
' **********************************************

' Copia a Formatação da Célula encontrada pelo Vlookup
' ******************************************************************
Range(CellOrigin).Copy
ActiveCell.PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
' ******************************************************************

VLOOKUPnew = Application.VLookup(ValueToLook, Interval, ColIndex, False)
End Function

要记住的一些提示:- 用户必须编写函数 - VLOOKUPnew - 就像他在 Excel 中编写普通的 vlookup 公式一样- 按 Enter 键后，该函数必须返回 vlookupnew 结果及其单元格格式

不要复制/粘贴单元格的格式。有什么建议吗？

我的目标的打印屏幕 Printscreen of excel

Answer 1

好吧，我们不能对人力资源总监说我们不能，不是吗？ :P尽管在自定义用户定义函数 (UDF) 中进行复制/粘贴等某些操作并不简单，但它仍然可以通过一种棘手的方式实现，在某种程度上，有一些限制，我将在最后指出。

下面的代码片段可以被视为实现任何类型“禁止的 UDF 操作” 的通用技术:以某种方式记住它们并让 Workbook_SheetCalculate 事件处理程序稍后执行它们。

这个想法是依靠 Workbook_SheetCalculate 事件，因为我们知道它会在计算完成后被调用，并且与 UDF 不同，它允许我们进行复制和粘贴。因此，UDF 将简单地通过一些变量传递范围(源和目标)。一旦计算完成并且UDF完成，Workbook_SheetCalculate将被自动调用；它将读取这些变量并完成 UDF 直接不允许的工作。

1) 在代码模块ThisWorkbook中:

Public Sources As New Collection, Destinations As New Collection

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    Application.ScreenUpdating = False
    On Error GoTo Cleanup
    For Each src In Sources
        src.copy
        Destinations(1).PasteSpecial xlPasteFormats
        Destinations.Remove 1
    Next

Cleanup:
    Application.CutCopyMode = False
    Set Sources = New Collection: Set Destinations = New Collection
    Application.ScreenUpdating = True
End Sub

2) 在用户定义函数中，不要直接执行复制/粘贴操作，而是将源单元格和目标单元格添加到 ThisWorkbook.Sources 和 ThisWorkbook.Destinations 分别是集合。也就是说，替换 UDF 代码的以下部分:

Range(CellOrigin).Copy
ActiveCell.PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False

这样:

ThisWorkbook.Sources.Add Range(CellOrigin)
ThisWorkbook.Destinations.Add Application.ThisCell

这将实现所需的行为。但正如我所说，有一些限制:

首先，如果使用自定义 UDF 的单元格数量太大(例如数千)，速度会有点慢。

第二点，也是更重要的一点，当您更改单元格的格式时，Excel 中的自动计算不会触发，而是仅在您更改其值时触发。因此，如果用户更改源单元格的格式但未更改其值，则该格式不会立即在目标处报告。用户可能需要手动强制计算，即按 F9。