如何将相同命名范围中的值从一个工作簿复制到另一个工作簿

Question

我有一个广泛的工作簿，它存在于多个版本中，其中包含数百个命名范围。 我想编写一个宏，将输入到某些命名范围的用户输入数据从本书的一个实例传输到另一个实例。 书中的命名范围遵循一定的约定，为了这个宏的目的，我想复制以"in_*"和"resetRange_*"开头的所有命名范围的值（它们是常量）

宏应该：

1. 打开源书（与当前书定义的命名范围大多相同）
2. 遍历源书的所有命名范围并找到like "in_*" or "resetRange_*"
3. 将命名范围内的值从源书复制到当前书（即使名称指的是区域）

我的主要问题是：

• 如何正确复制？当前的实现不起作用
• 有没有更好的方法来测试当前书中是否仍然存在源名称？

有问题的命名范围都以工作簿为范围。

宏运行无错误但不粘贴任何值的问题。当前书的命名范围保持为空，而源书包含数据 '

Public Sub TransferInputDataFromOtherTool()
                Dim sourceBook As Workbook
                Dim bookPath As Variant

'get source book
bookPath = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
If VarType(bookPath) = vbString Then
    Set sourceBook = Workbooks.Open(bookPath)
End If

On Error GoTo Cleanup

'@TODO transfer ranges _
    resetRange_* _
    in_*
'retrieving data
For Each n In sourceBook.Names
    On Error Resume Next
    rangeName = n.Name
    boola = ThisWorkbook.Names(n.Name)
    If boola Then
        On Error GoTo 0
        If rangeName Like "in_*" _
           or rangeName like "resetRange_*" Then
            'check for allow edit
            On Error Resume Next
            sourceBook.Activate
            source_value = n.refersToRange.Value
            ThisWorkbook.Activate
            Range(rangeName).Value = source_value
            'Debug.Print rangeName, source_value
            'Debug.Print Err.Description, Err.source
            On Error GoTo 0
        End If
        ' deleting all in_-values
    End If
Next n

'@TODO transfer tables
'ExcelHandling.EnableInteractivity

Cleanup:
On Error Resume Next
sourceBook.Close
On Error GoTo 0
End Sub

Answer 1

这里有一个代码示例可以提供帮助。请打开Option Explicit 并定义所有VBA 变量。看看这是否适合你：

编辑：添加范围检查以检测给定范围内的多个单元格，然后复制每个单元格

Option Explicit

Sub TransferInputDataFromOtherTool()
    Dim srcWB As Workbook
    Dim destWB As Workbook
    Dim filename As String
    Dim definedVariable As Name
    Dim singleCell As Range
    Dim singleCellLocation As String

    '--- the destination book is the currently active workbook from the user's perspective
    Set destWB = ThisWorkbook

    '--- source book from which to copy the data from - user selected
    filename = Application.GetOpenFilename("(*.xlsm), *.xlsm", Title:="Select source tool:")
    If filename = "False" Then
        '--- the user selected cancel
        Exit Sub
    ElseIf filename = destWB.Path & "\" & destWB.Name Then
        MsgBox "You can't open the same file that's already active. Select another file.", vbCritical + vbOKOnly
        Exit Sub
    Else
        Set srcWB = Workbooks.Open(filename)
    End If

    Debug.Print "values coming from " & filename
    For Each definedVariable In srcWB.Names
        If (definedVariable.Name Like "in_*") Or (definedVariable.Name Like "resetRange_*") Then
            '--- if the source/destination range is only a single cell, then
            '    it's an easy one-to-one copy
            Debug.Print definedVariable.Name & " refers to " & definedVariable.RefersTo;
            If destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 0 Then
                '--- do nothing
            ElseIf destWB.Names(definedVariable.Name).RefersToRange.Cells.Count = 1 Then
                Debug.Print " source value = '" & destWB.Names(definedVariable.Name).RefersToRange.Value & "'";
                Debug.Print " overwritten with '" & srcWB.Names(definedVariable.Name).RefersToRange.Value & "'"
                destWB.Names(definedVariable.Name).RefersToRange = srcWB.Names(definedVariable.Name).RefersToRange.Value
            Else
                '--- the source/target range has multiple cells, either contiguous
                '    or non-contiguous. so loop and copy...
                Debug.Print vbTab & "multiple cells in range..."
                For Each singleCell In destWB.Names(definedVariable.Name).RefersToRange
                    singleCellLocation = "'" & singleCell.Parent.Name & "'!" & singleCell.Address
                    Debug.Print vbTab & " source value = '" & singleCell.Value & "'";
                    Debug.Print "' overwritten with '" & srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value & "'"
                    singleCell.Value = srcWB.Sheets(singleCell.Parent.Name).Range(singleCell.Address).Value
                Next singleCell
            End If
        End If
    Next definedVariable

    srcWB.Close SaveChanges:=False
    Set srcWB = Nothing
    Set destWB = Nothing
End Sub