excel - Excel VBA - 如何从工作簿 B 传输形状并替换工作簿 A 中特定的现有形状?
问题描述
预先感谢您的任何帮助。我的知识是初级水平。我可以阅读代码,但写作困难。我不确定这个最新错误指的是哪一行。
另外,我认为总是有更好(更有效)的方式来编写代码。
这篇文章是在这篇文章之后发布的:VBA Excel - 如何将命名范围的值从工作簿 B 转移到工作簿 A 中相同/相似的命名范围中?
在排除了许多错误后,我终于收到错误:对象不支持此属性或方法。
第一篇参考文章:excel 将形状从一个工作表复制到另一个工作表
问题:形状将被复制,但无法正确定位。它被正确命名。
我正在尝试以下操作:
1. 将特定形状的形状属性存储在工作簿 A
2. 从工作簿 B 复制特定命名的形状
3. 将复制的形状粘贴到工作簿 A 中的特定工作表中
4. 将存储的形状属性应用于复制的形状
这是所有代码:
Sub Button_Transfer_FromOlderVersion()
' Start of Error Handling
On Error GoTo Errorcatch
' Declare string variable and use current open workbook filename as value
Dim WorkbookNameNew As String
WorkbookNameNew = ThisWorkbook.Name
' Declare string variable for 2nd workbook not yet identified
Dim WorkbookNameOld As String
' Find out the name of the 2nd workbook
' Declare string variable for finding and separating the filename from the path
Dim OldWorkbookFileName As String
' Show the open dialog and pass the selected file name to the string variable "OldWorkbookFileName"
OldWorkbookFileName = Application.GetOpenFilename
' If the user cancels finding the workbook file then exit subroutine
If OldWorkbookFileName = "False" Then Exit Sub
' Troubleshooting: Show me the filename with path of Workbook B
' MsgBox OldWorkbookFileName
' Troubleshooting: Show me the filename of Workbook A
' MsgBox WorkbookNameNew
' Open Workbook B which the user just selected
Workbooks.Open Filename:=OldWorkbookFileName
' Separate the filename from the path for Workbook B
WorkbookNameOld = Dir(OldWorkbookFileName)
' Troubleshooting: Show me the filename of Workbook B
' MsgBox WorkbookNameOld
' Temporarily change some settings to speed up the transfer process
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Transfer Values of Named Ranges from Workbook B
' Workbooks(WorkbookNameNew).Worksheets("WorksheetName").Range("NamedRange01").Value = Workbooks(WorkbookNameOld).Worksheets("WorksheetName").Range("NamedRange01").Value
' Unprotect specific Worksheet in Workbook A to help eliminate transfer issues of shapes
Sheet05.Unprotect Password:="MyPassword"
' Declare all variables
Dim worksheet01 As Worksheet
Dim worksheet02 As Worksheet
Dim PictureName01 As String
Dim PictureName02 As String
Dim shape01 As Shape
Dim shape02 As Shape
Dim shape03 As Shape
Dim shapeTop As Long
Dim shapeLeft As Long
Dim shapeHeight As Long
Dim shapeWidth As Long
'******* ******* ******* SHAPE 01
' Set variables so they are not equal to Nothing
Set worksheet01 = Workbooks(WorkbookNameNew).Worksheets("WorksheetName")
' Identify the name of the existing shape
PictureName01 = "WorkbookNewNamedPicture01"
Set shape01 = worksheet01.Shapes(PictureName01)
Set worksheet02 = Workbooks(WorkbookNameOld).Worksheets("WorksheetName")
' Identify the name of the existing shape
PictureName02 = "WorkbookOldNamedPicture01"
Set shape02 = worksheet02.Shapes(PictureName02)
Set shape03 = shape01
' Capture properties of exisitng picture such as location and size
' Measurements in points must be converted from desired inches. Use http://www.thecalculatorsite.com/conversions/length/points-to-inches.php
shapeTop = shape01.Top
shapeLeft = shape01.Left
shapeHeight = shape01.Height
shapeWidth = shape01.Width
' Copy first shape in Workbook B
worksheet02.Shapes(PictureName02).Copy
' Delete existing shape in Workbook A
worksheet01.Shapes(PictureName01).Delete
' Paste the copied shape into Workbook A
worksheet01.Paste
' Identify and select the most recently added shape in Workbook A
Set shape03 = worksheet01.Shapes(worksheet01.Shapes.Count)
' Reapply shape properties to the recently added shape in Workbook A
shape03.Top = shapeTop
shape03.Left = shapeLeft
shape03.Height = shapeHeight
shape03.Width = shapeWidth
' Apply expected name to the recently added shape in Workbook A
shape03.Name = "WorkbookNewNamedPicture01"
'******* ******* ******* SHAPE 02
'******* ******* ******* SHAPE 03
'******* ******* ******* SHAPE 04
'******* ******* ******* SHAPE 05
'******* ******* ******* SHAPE 06
' User Feedback of successful transfer and name of Workbook B
MsgBox ("TRANSFER COMPLETED FROM:" & " " & WorkbookNameOld)
' Re-protect specifc worksheet in Workbook A that received new shapes from Workbook B
Sheet05.Protect Password:="MyPassword"
' Restore the settings that were changed temporarily to speed up the transfer process
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
' Finish Error Handling
Errorcatch:
MsgBox Err.Description
End Sub
解决方案
如评论中所述,您在线上出错了Set shape03 = worksheet01.Shapes(shape03.Shapes.Count)
你不能数一个形状对象。相反,使用:
Set shape03 = worksheet01.Shapes(worksheet01.Shapes.Count)
推荐阅读
- excel - 在 excel 2019 中使用标准进行文本连接
- llvm - 如何重新洗牌llvm中的数组访问?
- android - custom_marker_icon >=0.2.0,版本解析失败
- android - 有没有办法知道哪个应用在 Android 上打开了移动数据?
- flutter - 如何扩展文本按钮?
- python - 在 Django 中加载静态文件时出错
- reactjs - 为什么我的类方法可以在 React 中工作而没有显式地将它绑定到“this”?
- node.js - 字典无法在赛普拉斯中排序
- javascript - 如何在不删除先前值的情况下将值存储在数组中
- go - 在 POST 请求中格式化正文