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

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

macros应该是：

1. 打开源书（其中大部分与当前书中定义的命名范围相同）
2. 迭代源文件的所有命名范围，并findlike "in_*" or "resetRange_*"
3. 将来源图书中指定范围的值复制到当前图书（即使名称涉及区域）

我的主要问题是：

• 我如何正确复制？ 目前的实施不起作用
• 有没有更好的方法来testing当前书籍中是否存在源名称？

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

macros运行错误，但不会粘贴任何值的问题。 当前图书的命名范围保持空白，而源书包含数据“

 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并定义所有的VBAvariables。 看看这是否适合你：

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

 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