时间戳

首页 > 解决方案 > 使用 vba 从主工作簿复制的工作表中重命名或添加宏到模块

vba - 使用 vba 从主工作簿复制的工作表中重命名或添加宏到模块

问题描述

我一直在研究一个文件，我将使用许多不同的功能，并且我使用用户表单作为“控制面板”——我一直试图让一个功能在这里工作，但我真的找不到解决方案。也许这里有人可以提供帮助？我不得不说我对 vba 的经验还很远，但我发现尝试和学习真的很有趣。

我的问题：我有一个代码，可以在其中将形状添加到列表中，还具有单击和缩放功能-我还有将这张表复制到新工作簿中并将其另存为 .xlsm 的代码，并且我在实际表中有宏我复制了-到目前为止一切都很好。
但是我没有设法让宏在新工作簿中工作，因为我在工作表中有宏，新工作簿将宏称为“sheet9.Zoom”，而不是实际上只是将其称为 Zoom - 是否有可能以某种方式在vba代码中重命名复制版本中的宏或确保新工作簿不将其称为“sheet9.Zoom”，以便在单击图片进行缩放时找到宏？这里的一切都是使用表单完成的，因为我想让它对我的同事尽可能地友好:)

这是我用于将缩放功能添加到形状的代码：

Private Sub Commandbutton8_Click()
Set myDocument = Worksheets("Import")
myDocument.Shapes.SelectAll

Set sr = Selection.ShapeRange

Selection.OnAction = "Zoom_Click"
Range("e1").Select


End Sub

Sub Zoom_Click()

Dim shp As shape
    Dim big As Single, small As Single
    Dim shpDouH As Double, shpDouOriH As Double
    big = 0.8
    small = 0.11
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(Application.Caller)
    With shp
        shpDouH = .Height
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        shpDouOriH = .Height
     
        If Round(shpDouH / shpDouOriH, 2) = big Then
            .ScaleHeight small, msoTrue, msoScaleFromTopLeft
            .ScaleWidth small, msoTrue, msoScaleFromTopLeft
            .ZOrder msoSendToBack
        Else
            .ScaleHeight big, msoTrue, msoScaleFromTopLeft
            .ScaleWidth big, msoTrue, msoScaleFromTopLeft
            .ZOrder msoBringToFront
        End If
    End With
End Sub

这是用于将工作表复制到新工作簿。

Private Sub CommandButton6_Click()


Dim MyPath As String

Dim MyFileName As String

Dim DateString As String

DateString = Format(Now(), "yyyy-mm-dd_hh_mm_ss_AM/PM")

MyFileName = DateString & "_" & "Pricelist"

If Not Right(MyFileName, 4) = ".xlsm" Then MyFileName = MyFileName & ".xlsm"

Sheets("Import").Copy


With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = ""
    .AllowMultiSelect = False
    .InitialFileName = "C:" '<~~ The start folder path for the file picker.
    If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"

End With

NextCode:

With ActiveWorkbook
.SaveAs Filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
.Close False

End With

End Sub

希望这能解释一下:)

标签： vbacopy

解决方案

您可以重新链接复制工作表上的形状宏：

Dim sh As Shape, wbNew As Workbook, ws As Worksheet

ThisWorkbook.Sheets("Import").Copy
Set wbNew = ActiveWorkbook
Set ws = wbNew.Sheets("Import")

For Each sh In ws.Shapes
    'relink only if has action set
    If Len(sh.OnAction) > 0 Then
        sh.OnAction = ws.CodeName & ".Zoom_Click"
    End If
Next sh

'save the new workbook...

另请参阅：https ://www.thespreadsheetguru.com/blog/correcting-shape-assigned-macro-links-after-copying-worksheet-vba ，它具有良好的通用方法。

推荐阅读