给予独特的随机名称复制粘贴的形状
我正试图复制和粘贴从sheet2到VBA中的sheet1形状。 但是，粘贴多次后。 我注意到形状共享相同的名称，这意味着他们共享相同的macros，macros只适用于粘贴具有相同名称的第一个形状。 为了解决这个问题，我使用下面的代码在复制后在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
但是，我发现在表1中可能仍然存在随机名称RL不唯一的情况，尽pipe这种情况非常罕见，但这种情况发生了很多次。 因此，我决定在函数RL()添加一个检查来查看生成的RL是否已经存在于sheet1 。 不过，我发现这很耗时，因为sheet1中有很多形状。 有没有有效的方法，以便我可以复制和粘贴唯一？
然而，我发现在表1中可能仍然存在随机名RL不唯一的情况，尽pipe这种情况非常罕见，但这种情况确实发生了很多次。
这是我用来获取随机名称。 很直，很简单。 否两个名字将是相同的，除非你拨弄系统时钟。
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
OUTPUT
Shp18112013133835168714332 Shp18112013133835168714363 Shp18112013133836168714426 Shp18112013133836168714457 Shp18112013133836168714504 Shp18112013133836168714550 Shp18112013133836168714597 Shp18112013133836168714644 Shp18112013133836168714691 Shp18112013133836168714738
Siddhart的解决scheme看起来不错，但是我不喜欢你需要等待每个贴子一秒，（也很难跟随的名字）。 通过这种方法，命名是基于可用的编号增加+1。 在目标工作表中find的形状（在本例中为“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
你可以随时调用这个macros，因为它很快（甚至对于数千个形状），并不影响其他macros的整体运行时间。 也许这将涵盖评论中所述的问题。 🙂
问题不在于粘贴的形状具有相同的名称，因为每个新粘贴的名称都会加1。 您可以通过单击function区的“主页”选项卡上的“编辑”部分中的“查找并select”select窗格来检查。
当您复制并粘贴具有分配给它的macros的形状时，macros分配也被复制。
如果你想要后续的复制/粘贴没有macros分配的话
Worksheets(1).Shapes(2).OnAction = ""
将重置macros分配。
你如何开火以循环你的形状，是另一个问题。 没有一个工作表事件，我知道这是当一个形状被粘贴到工作表时触发。