Question

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

宏应该是：

打开源书（其主要名称范围与当前书籍相同）
遍历源书的所有命名范围，找到like "in_*" or "resetRange_*"
将指定范围内的值从源书复制到当前书籍（即使名称指的是区域）

我的主要问题是：

我该怎么正确复制？当前的实现不起作用
是否有更好的方法来测试当前图书中是否仍存在源名称？

所讨论的命名范围都限定在工作簿中。

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

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

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

1 个答案: