将工作表从工作簿复制到另一个工作簿，并将 ActiveX 控件、形状和图表的所有引用修改到目标工作簿

问题描述 投票：0回答：2

假设我有两个工作簿（工作簿1和工作簿2），我需要从工作簿1复制一张工作表到工作簿2。
复制的工作表的名称，例如“Board”有（ActiveX Controls），它引用了分配有宏的子例程，
还有像（圆角矩形，八角形）和图片这样的形状，它们引用了单元格值或分配有宏的子例程，
复制的工作表还具有图表，其中引用了单元格范围。
复制表的问题是所有子程序和形状 公式仍然参考源工作簿（

workbook1
）。
注意：（所有引用的工作表名称和所有调用的过程都存在于工作表已复制到的工作簿中）。
所以我需要修改复制的工作表以制作子程序和形状公式的所有引用（工作簿2）。
我使用了下面的宏，它仅在处理工作表并修改（ActiveX 控件）分配了宏的子例程时才成功。
但对于其他形状（圆角矩形、八边形等）我有

运行时错误“438”：对象不支持此属性或方法

在这一行

If shp.Formula <> "" Then

并且更改图表的代码没有任何效果（没有引发错误）。

Option Explicit
Option Compare Text

Sub Copy_Sheet_to_another_Workbook()           'Assumes this code is found in Workbook1 (ThisWorkbook)
    
    Dim srcWs As Worksheet
    Dim dstWb As Workbook
    Dim dstWs As Worksheet
    Dim shp As Shape
    Dim srcWbName As String
    Dim dstWbName As String
    
    With Application
      .Calculation = xlCalculationManual
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
    End With
    
    Set srcWs = ThisWorkbook.Sheets("Board")                             'name of the sheet to be copy
    Set dstWb = Workbooks.Open("C:\Users\xxx\Desktop\Workbook2.xlsb")    'destination Workbook
    srcWs.Copy Before:=dstWb.Sheets(1)
    Set dstWs = dstWb.Sheets(2)
    
    srcWbName = ThisWorkbook.name
    dstWbName = dstWb.name
      
'Update VBA references to macros/subroutines in shapes with macros assigned
   For Each shp In dstWs.Shapes
        If shp.OnAction <> "" Then
            If InStr(1, shp.OnAction, srcWbName, vbTextCompare) > 0 Then
                shp.OnAction = Replace(shp.OnAction, srcWbName, dstWbName)
            End If
        End If
    Next shp

'Update shapes with cell references in the formula
    For Each shp In dstWs.Shapes
        If shp.Formula <> "" Then
            If InStr(1, shp.Formula, srcWbName, vbTextCompare) > 0 Then
                shp.Formula = Replace(shp.Formula, srcWbName & "!", dstWbName & "!")
            End If
        End If
    Next shp

'Update chart references
    For Each chartObj In dstWs.ChartObjects
        With chartObj.Chart
            Dim srs As Series
            For Each srs In .SeriesCollection
                If InStr(1, srs.Formula, srcWbName, vbTextCompare) > 0 Then
                    srs.Formula = Replace(srs.Formula, srcWbName & "!", dstWbName & "!")
                End If
            Next srs
        End With
    Next chartObj

    dstWb.Activate
    With Application
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
      .EnableEvents = True
      .DisplayAlerts = True
    End With
    
End Sub

更新1 - 似乎我必须选择每个形状，然后检查其公式并相应地修改它，
因为并非每个形状都有公式，所以我必须使用错误处理。
这种方法的缺点是它不适用于分组形状。

'Update shape formulas by selecting each shape (for shapes with cell references)
    For Each shp In dstWs.Shapes
      On Error Resume Next             'Ignore errors for shapes without a formula
       shp.Select
        If Selection.Formula <> "" Then
            If InStr(1, Selection.Formula, "[" & srcWbName & "]", vbTextCompare) > 0 Then
                Selection.Formula = Replace(Selection.Formula, "[" & srcWbName & "]", "")
            End If
        End If
      On Error GoTo 0                  'Reset error handling
    Next shp
excel vba
2个回答
0
投票

这似乎有点令人困惑。 形状对象没有属性公式，您也可以向形状添加公式，它将被识别为形状。 但这些形状是特殊的物体，例如椭圆形 -> 椭圆形 假设您插入一个椭圆形（我将使用它作为可以有公式的所有可能形状的示例）并给它一个公式。它将作为形状被发现，但不会呈现公式属性。即使你寻找物体。 问题可能是，椭圆形是隐藏元素，只需在对象资源管理器中查看并显示隐藏元素即可。

我想你必须知道，你使用哪些特殊类型的形状来迭代它们

Sub JustToShow()
Dim ov As Oval
For Each ov In ActiveSheet.Ovals
Debug.Print ov.Formula
Next ov
End Sub

但我认为，这种使用形状和公式的方式无论如何都更加重要。它们可能非常不稳定。

0
投票

请尝试下一个测试子程序。

  1. 第一个尝试展示如何使用 Solar Mike 的建议保持相同的公式：
Sub ModifyFormulaMemorizeRange()
  Dim wsSource As Worksheet, wsDest As Worksheet, rngFormula As Range, rngFormula1 As Range, cel As Range
  Set wsSource = ActiveSheet
  
  Set rngFormula = wsSource.UsedRange.SpecialCells(xlCellTypeFormulas)
  For Each cel In rngFormula.Cells
    cel.Formula = VBA.Replace(cel.Formula, "=", "xyz#@") 'use a string not probable to be found between existing...
  Next cel
  Stop 'please, check the transformed formulas
  
  'copy the sheet after the active one:
  wsSource.Copy after:=wsSource
   Stop 'please, see the newly copied sheet
   
  Set wsDest = wsSource.Next
  Set rngFormula1 = wsDest.Range(rngFormula.Address)

  For Each cel In rngFormula.Cells
    cel.Formula = VBA.Replace(cel.Formula, "xyz#@", "=")
  Next cel
  wsSource.Calculate
  Stop 'see the original sheet restored formulas...
  
  'Change back formulas in the copied cells
  For Each cel In rngFormula1.Cells
    cel.Formula = VBA.Replace(cel.Formula, "xyz#@", "=")
  Next cel
  wsDest.Calculate
  Stop 'check the copied cells formulas...
End Sub
  1. 下一篇尝试解释如何更改形状公式，如果出现以下情况：
Sub MemorizeShapesTextFormula()
  Dim sh As Shape, ws As Worksheet, k As Long
  
  Set ws = ActiveSheet
  ReDim arrShFormula(ws.Shapes.Count)
  For Each sh In ws.Shapes
    If CBool(sh.TextFrame2.HasText) Then
        sh.Select
        With Selection
            If isLinkedCell(.Formula, .Text) Then
                arrShFormula(k) = sh.Name & "|=" & .Formula: k = k + 1
            End If
        End With
    End If
  Next sh
  If k > 0 Then ReDim Preserve arrShFormula(k - 1)
  Debug.Print Join(arrShFormula, " ") 'just to see what has been memorized
  
End Sub

Function isLinkedCell(cellAddress As String, shText As String) As Boolean
  On Error Resume Next
   If Range(cellAddress).Value = shText Then isLinkedCell = True
  On Error GoTo 0
End Function

1.b.如何使用上面加载的数组来更改复制形状的公式：

Sub AdaptShapesTextFormulas()
  Dim wsSource As Worksheet, sh As Shape, i As Long
  
  Set wsSource = ActiveSheet.Next 'mentain selected the sheet where the array has been loaded...
  For i = 0 To UBound(arrShFormula)
    wsSource.Shapes(Split(arrShFormula(i), "|")(0)).Select
    Selection.Formula = Split(arrShFormula(i), "|")(1)
  Next i
  
End Sub

已编辑：

要处理分组形状，请使用下一个测试子：

Sub testGroupMembersFormula()
 Dim sh As Shape, i As Long
 
 For Each sh In ActiveSheet.Shapes
    If sh.Type = msoGroup Then
        For i = 1 To sh.GroupItems.Count
            Debug.Print sh.GroupItems(i).Name
             sh.GroupItems(i).Select
             Debug.Print Selection.Formula
        Next i
    End If
 Next sh
End Sub
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.