Excel，链接2个单元格以具有相同的格式

Question

在 Excel 中，我想链接不同工作表中的 2 个单独的单元格，以具有完全相同的格式。如果第一个单元格发生更改，我还需要第二个单元格自动更新。

这可能吗？

非常感谢。

Answer 1

下面的 VBA 代码可以完成这项工作。

在这里您可以查看示例:

https://github.com/thanosa/excel-vba-collection/tree/master/link_formatted_cells

您必须指定:

1. 源工作表名称
2. 目标工作表名称(可以相同)
3. 来源 ID 列
4. 来源信息列
5. 目标 ID 列
6. 目的地信息列

它的作用是:

1. 从目标表中读取目标 ID
2. 在源表中查找目标 ID 以找到该行
3. 根据上面找到的行和源信息列从源表中复制单元格
4. 将单元格按原样粘贴到当前行和目的地信息列的“目的地”工作表中。

Const MAX_ROWS = 1000000

Private Sub CopyFormatted()
    ' Looks-up the destination id into the source look-up column to retrieve the row number
    ' Then it copies the source cell into the destination cell
    ' This is done to copy the format and the within cell new lines

    ' Layout dependent for the Destination
    dstWsName = "sheet1"
    dstFirstRow = 2
    dstIdCol = "A"
    dstWriteCol = "B"

    ' Layout dependent for the Source
    srcWsName = "sheet1"
    srcFirstRow = 2
    srcLookupCol = "D"
    srcReadCol = "E"

    Call performancePre

    Call lookUpCell(dstWsName, dstFirstRow, dstIdCol, dstWriteCol, _
                    srcWsName, srcFirstRow, srcLookupCol, srcReadCol)

    Call performancePost

End Sub


Private Sub lookUpCell(dstWsName, dstFirstRow, dstIdCol, dstWriteCol, _
                       srcWsName, srcFirstRow, srcLookupCol, srcReadCol)
    ' Reads a value in

    Dim srcWs As Worksheet
    Dim dstWs As Worksheet

    Set srcWs = ActiveWorkbook.Sheets(srcWsName)
    Set dstWs = ActiveWorkbook.Sheets(dstWsName)

    Dim sourceIdsVector As Range
    Set sourceIdsVector = srcWs.Range(srcLookupCol & srcFirstRow & ":" & srcLookupCol & MAX_ROWS)

    ' Initialization
    dstWriteRow = dstFirstRow
    Do
        srcRow = Empty
        searchId = dstWs.Range(dstIdCol & dstWriteRow).Value

        ' Make sure the id is not empty
        If searchId = vbNullString Then Exit Do

        ' Lookup the id to find the row number
        For Each cell In sourceIdsVector.Cells
            If cell.Value = "" Then Exit For

            If cell.Value = searchId Then
                srcRow = cell.Row
                Exit For
            End If
        Next cell

        ' If the search succeeds id does the copy paste of the cells.
        If srcRow <> Empty Then

            Dim srcCell As Range
            Set srcCell = srcWs.Range(srcReadCol & srcRow)

            Dim dstCell As Range
            Set dstCell = dstWs.Range(dstWriteCol & dstWriteRow)

            Call CopyPasteRange(srcWs, srcCell, dstWs, dstCell)

        End If

        ' Update
        dstWriteRow = dstWriteRow + 1
    Loop

End Sub


Private Sub CopyPasteRange(srcWs As Worksheet, srcRange As Range, dstWs As Worksheet, dstRange As Range)
    ' Copy a ranges and pastes it to another
    srcWs.Select
    srcRange.Select
    Selection.Copy

    dstWs.Select
    dstRange.Select
    ActiveSheet.Paste

    Application.CutCopyMode = False

End Sub


Private Sub performancePre()
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False 'note this is a sheet-level setting
End Sub


Private Sub performancePost()
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True 'note this is a sheet-level setting
End Sub