excel - 如何引用许多填充文本的单元格并拥有所有格式副本？

Question

我先写了一篇文章，但精简到了这一点：我有很多数据，需要能够让我的 Vlookup 函数复制格式以及文本本身。

我从“类似问题”列表中找到了这个：引用一个单元格但保留源单元格中的文本格式，其中包含此代码片段：

Private changing As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Target.Address = [A1].Address Or changing Then Exit Sub
changing = True
[A1].Copy [B1]
changing = False

End Sub

现在，这实际上看起来对我有用。但是，我需要一种方法让它检查接收表上 24 个单元格中的一个，并复制源表上正确源单元格（3500+ 行 x 60+ 列）的内容。现在，使用 VLookup 找到源单元格；但是我怎样才能绑定上面的宏来检查正确的源单元格呢？我可以制作上述代码片段的 24 个副本，每个目标单元格一个，我认为这将只在目标单元格发生更改时才检查它们，但代码片段中的 B1 引用不起作用，因为源单元格随每个条目而变化。

简单地说：我不擅长 VBA，不知道如何一起使用 VLookup 和上面的代码片段。

谢谢你的想法！

---

编辑：有人问我有关如何找到源数据的更多详细信息。我有一个带有四个下拉列表的可打印页面（它们对数据库的标题列使用验证），让我从我的数据库中（分别）选择四个条目。这些选择然后触发将相关数据从数据库移植到打印页面的 VLookup。该数据库是 3556 行 x 60 列，其中只有 17 个被拉到打印页面。

这些数据点中的大多数都被很好地拉过来了。将目标单元格设置为“缩小以适合”足以确保数据适合。但是，对于其中的五个，“缩小以适应”不可用，因为它们（通常）是多行条目，因此必须启用“自动换行”，这使得“缩小以适应”不可用。这意味着对于打印页面上的四个选项中的每一个，我必须手动适应这 5 个数据点的文本。这可能会非常耗时，尤其是当我有一百个或更多要打印的时候。

或者，由于我已经完成了大部分工作，我可以手动编辑每个原始条目（将列宽和字体设置为与打印页面相同），并且一旦它们适合，就可以将它们整个复制到目的地打印页面上的单元格。

因此，理想情况下，可以将上面提出的代码混合在一起，以检查各种 24 个单元格（它们不是连续的）中的每一个何时更改，然后找到正确的源单元格（每个更改的单元格只会从一个单元格接收数据在特定列中，例如，H5、H77、H149 和 H221 将始终从数据库中的 CD 列接收数据，而 V5、V77、V149 和 V221 将始终从数据库中的 BZ 列接收数据) 并复制源数据（包括所有文本格式）。

---

编辑 2：指向我的电子表格的链接。应该从...开始这样做：p

标签： excelvba

Answer 1

像这样使用循环（基于您发布的代码）：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng
    Set rng = Application.Intersect(Target, Me.Range("A1:A24"))
    'Any changes in the range of interest?
    If Not rng Is Nothing Then
        Application.EnableEvents = False  'suspend event handling
        'Loop over the changed cells...
        For each c in rng.cells
            ProcessChange c '<< handle any lookups
        Next c
        Application.EnableEvents = True 'restore event handling
    End If

End Sub

编辑：您发布的工作簿并没有太大帮助，因为它太复杂了，我无法花时间弄清楚它，但这里有一个通用方法，它应该为您提供一个框架，让您可以从“列表”中查找匹配项和复制信息/格式床单。

'called for each changed cell
Sub ProcessChange(c As Range)

    Dim m, shtLookup As Workbook, valueCell As Range

    Set shtLookup = ThisWorkbook.Sheets("Database")

    'find the new value in the lookup sheet (in the first column)
    Set m = Application.Match(c.Value, shtLookup.Range("A:A"), 0)
    If Not IsError(m) Then

        'got a match: get the corresponding cell from col CD
        Set valueCell = shtLookup.Range("CD:CD").Cells(m)

        'do something with this cell
        With c.Offset(5, 5) '<< some place relative to the changed cell
            .Value = valueCell.Value   'copy value
            .Width = valueCell.Width   'copy width
            .Height = valueCell.Height 'copy height
        End With
    Else
        MsgBox "no match for '" & c.Value & "'"
    End If

End Sub