Question

我正在尝试将形状从sheet2复制并粘贴到VBA中的sheet1。然而，经过多次粘贴。我注意到形状共享相同的名称，这意味着它们共享相同的宏，宏仅应用于粘贴有相同名称的第一个形状。为了解决这个问题，我使用以下代码在复制后随机重新生成sheet1中的形状名称。

Public Function RL()
    Dim Rand As String
    Dim i As Integer, XSet As Integer
    Dim MyCase As Integer
    Application.Volatile
    MyCase = 38: XSet = 85
    Do
        i = i + 1
        Randomize
        Rand = Rand & Chr(Int((XSet) * Rnd + MyCase))
    Loop Until i = 5
    RL = "X" & Rand
End Function

但是，我发现可能仍然存在随机名称RL在sheet1中不唯一的情况，虽然这种情况非常罕见，但确实发生过很多次。因此，我决定在函数RL()中添加一个检查，以查看生成的RL是否已存在于sheet1中。但是，由于sheet1中有很多形状，我发现这非常耗时。有没有什么有效的方法可以复制和粘贴？

Answer 1

然而，我发现可能仍然存在随机名称RL在sheet1中不唯一的情况，虽然这种情况非常罕见，但确实发生了很多次。

这是我用来获取随机名称的方法。非常简单直接。没有两个名字是相同的，除非你摆弄系统时钟。

Option Explicit

Sub Sample()
    Dim i As Long

    For i = 1 To 10
        Debug.Print GetNewShpName
    Next i
End Sub

Function GetNewShpName() As String
    GetNewShpName = "Shp" & Format(Now, "ddmmyyyyhhmmss")
    Wait 1
End Function

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

示例名称

Shp18112013120449
Shp18112013120450
Shp18112013120451
Shp18112013120452
Shp18112013120453
Shp18112013120454
Shp18112013120455
Shp18112013120456
Shp18112013120457
Shp18112013120458

修改

与上面的
相比，这是一种更快的方法
Option Explicit Private Declare Function GetTickCount Lib "kernel32" () As Long Sub Sample() Dim i As Long For i = 1 To 10 TickTock Debug.Print GetNewShpName Next i End Sub Function GetNewShpName() As String GetNewShpName = "Shp" & Format(Now, "ddmmyyyyhhmmss") & GetTickCount() End Function Public Sub TickTock() Dim j As Long, r As Double For j = 0 To 1000000 r = Rnd Next End Sub

<强>输出

Shp18112013133835168714332 Shp18112013133835168714363 Shp18112013133836168714426 Shp18112013133836168714457 Shp18112013133836168714504 Shp18112013133836168714550 Shp18112013133836168714597 Shp18112013133836168714644 Shp18112013133836168714691 Shp18112013133836168714738

Answer 2

Siddhart的解决方案看起来足够坚固，但我不喜欢你需要等待每一个粘贴，（以及难以遵循的名称）。通过这种方法，命名根据可用的no增加+ 1。在目标工作表中找到的形状（在本例中为“PasteSheet”）。关键要素是：

ImcrementValue = Paste_Sheet.Shapes.Count和
Paste_Sheet.Shapes(ImcrementValue).Name = "Shape" & ImcrementValue

守则：

Sub SetShapeName()
Dim Copy_Sheet As Worksheet: Set Copy_Sheet = Sheets("Sheet1")
Dim Paste_Sheet As Worksheet: Set Paste_Sheet = Sheets("Sheet2")
Dim IncrementValue As Integer

For i = 1 To Copy_Sheet.Shapes.Count
    ImcrementValue = Paste_Sheet.Shapes.Count
    If IncrementValue = 0 Then IncrementValue = 1 'Solves an error if there are no Shapes in the destionation sheet
    Copy_Sheet.Shapes(i).Copy
    Paste_Sheet.Paste
    On Error Resume Next 'Related to same issue as above
    Paste_Sheet.Shapes(ImcrementValue).Name = "Shape" & ImcrementValue
Next i
End Sub

代码本身将所有形状从sheet1复制到sheet2，但如果这不是你想要的，你应该专注于命名方法。希望这有助于加快复制/粘贴和“难以理解”的名称;）

修改此方法是前一种方法的替代方法，这不是计算目标工作表中的形状，而是使用第三张工作表中的增量值（我喜欢称之为MacroKeys）

Sub SetShapeName_ver2() Application.ScreenUpdate = False Dim Paste_Sheet As Worksheet: Set Paste_Sheet = Sheets("Sheet2") Dim MacroKeys As Worksheet: Set MacroKeys = Sheets("MacroKeys") Dim IncrementalValue As Long For i = 1 To Paste_Sheet.Shapes.Count ImcrementValue = MacroKeys.Range("A1").Value Paste_Sheet.Shapes(i).Name = "Shape" & ImcrementValue MacroKeys.Range("A1").Value = ImcrementValue + 1 Next I Application.ScreenUpdate = True End Sub

您可以随时调用此宏，因为它很快（即使是数千种形状）并且不会影响其他宏的整体运行时间。也许这将涵盖评论中陈述的问题。：）

Answer 3

问题不在于粘贴的形状具有相同的名称，因为每个新粘贴的名称都会增加1。您可以点击查找＆amp;选择＆gt;功能区“主页”选项卡上“编辑”部分的选择窗格。

复制并粘贴分配了宏的形状时，也会复制宏分配。

如果您希望后续复制/粘贴没有宏分配，那么

Worksheets(1).Shapes(2).OnAction = ""

将重置宏分配。

如何解雇你的形状，是另一个问题。当形状粘贴到工作表中时，没有我知道的工作表事件被触发。

为复制粘贴的形状提供唯一的随机名称

3 个答案: