CODEWITHSUNDEEP
vbaexcel
fyr91
fyr91

Reputation: 1293

Giving uniquely random names to copy-pasted shapes

I am trying to copy and paste shape from sheet2 to sheet1 in VBA. However, after pasting multiple times. I notice that the shapes are sharing the same name, which means they are sharing the same macro and the macro is only applied to the first shape pasted with the same name. To solve this, I have used the following code to randomly regenerate the shape's name in sheet1 after copying.

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

However, I found that there may still be cases where random name RL are not unique in sheet1, Although it is pretty rare, this did happen quite a few times. Thus, I decided to add in a check inside the function RL() to see whether the RL generated have already existed in sheet1. However, I found this quite time consuming as there are a lot of shapes in sheet1. Is there any efficient way so that I could copy and paste uniquely?

Upvotes: 0

Views: 1437

Answers (3)

Takedasama
Takedasama

Reputation: 387

Siddhart's solution looks solid enough, but I don't like that you need to wait a sec for each paste, (and also the hard-to-follow nameings). By this method the naming is incremented + 1 based on the available no. of shapes found within the target sheet (in this case the "PasteSheet"). The key elements are:

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

The Code:

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

The code itself copies all shapes from sheet1 onto sheet2, but you should focus on the naming menthod if this is not what you are looking for. Hope this helps with speeding up the copy/pasting and the "hard-to-follow" names ;)

Edit: This method is an alternative to the previous, and this is not counting the shapes within the target sheet, but uses an incremental value from a 3rd sheet (which I like to call 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

You can call this macro whenever you like, as it's fast (even for thousands of shapes) and doesn't impact the overall running time of other macros. Maybe this will cover the issues stated in the comments. :)

Upvotes: 1

Siddharth Rout
Siddharth Rout

Reputation: 149297

However, I found that there may still be cases where random name RL are not unique in sheet1, Although it is pretty rare, this did happen quite a few times.

This is what I use to get random names. Very straight and simple. No Two names will be same unless you fiddle with the system clock.

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

Example Names

Shp18112013120449
Shp18112013120450
Shp18112013120451
Shp18112013120452
Shp18112013120453
Shp18112013120454
Shp18112013120455
Shp18112013120456
Shp18112013120457
Shp18112013120458

EDIT

Here is a faster method as compared to above

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

Upvotes: 2

Mark Fitzgerald
Mark Fitzgerald

Reputation: 3068

The problem is not that the pasted shapes have the same name because the names increment by 1 for each new paste. You can check this by clicking Find & Select > Selection Pane from the Editing section on the Home tab of the Ribbon.

When you copy and paste a shape that has a macro assigned to it, the macro assignment is copied too.

If you want subsequent copy/pastes to have no macro assignment then

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

will reset the macro assignment.

How you fire that to loop through your shapes, is another question. There isn't a worksheet event that I know of that is fired when a shape is pasted into a sheet.

Upvotes: 0

Related Questions