Bulk paste cell content into shape

[mdubs91]

I'm a big fan of this forum as it has helped me with coding more times than I can count, but I think I've finally found a question that hasn't been asked yet.

Scenario: I have an excel workbook with a large number of worksheets and each sheet has a number of shapes on them with associated text. I need to translate all this text, so I was looking to do it the easiest way possible. I was able to get the following code to work to copy all the shape text into one worksheet. Worked like a charm!

Private Sub CommandButton1_Click()
Dim WS_Count As Integer
         Dim I As Integer
         Dim shp As Shape
Dim strText As String

         ' Set WS_Count equal to the number of worksheets in the active
         ' workbook.
         WS_Count = ActiveWorkbook.Worksheets.Count

         ' Begin the loop.
         For I = 1 To WS_Count

For Each shp In Worksheets(I).Shapes

On Error Resume Next
strText = shp.TextFrame.Characters.Text
If Err.Number > 0 Then
Err.Clear
Else
If Len(strText) > 0 Then
Cells(Me.Rows.Count, 1).End(xlUp).Offset(1).Value = strText
End If
End If

Next

         Next I
End Sub

I have a lovely worksheet that has all the text in every shape. What I want to do now is input the french in the cell next to it and then clicking the next command button, it runs through the shapes and replaces the text with the french. I thought it would be as simple as inverting the initial code, but it has proven more tricky than that. Here is what I have:

Private Sub CommandButton2_Click()

Dim WS_Count As Integer
         Dim I As Integer
         Dim cell As Integer
        
         Dim shp As Shape
Dim strText As String

cell = 2

         ' Set WS_Count equal to the number of worksheets in the active
         ' workbook.
         WS_Count = ActiveWorkbook.Worksheets.Count

         ' Begin the loop.
         For I = 1 To WS_Count

For Each shp In Worksheets(I).Shapes
On Error Resume Next
If Err.Number > 0 Then
Err.Clear
Else
If Len(strText) > 0 Then
strText = Me.Cells(2, cell).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1
End If
End If

Next

         Next I

End Sub

It doesn't seem to do anything.

If someone can solve this for me I'd be forever grateful! Thank you in advance!

 

[Akuini]

Hi, @mdubs91

Try it without checking the string:

If Len(strText) > 0 Then
strText = Me.Cells(2, cell).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1
End If

And where is the French text located, in row 2 or col B?
If it's in col B then it should be:

strText = Me.Cells(cell, 2).Value

 

[mdubs91]

Hi, @mdubs91

Try it without checking the string:

If Len(strText) > 0 Then
strText = Me.Cells(2, cell).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1
End If

And where is the French text located, in row 2 or col B?
If it's in col B then it should be:

strText = Me.Cells(cell, 2).Value

Thanks for responding so quickly Akuini. The column is indeed B and starts at row 2, so I made the updates as suggested:

Private Sub CommandButton2_Click()

Dim WS_Count As Integer
Dim I As Integer
Dim cell As Integer

Dim shp As Shape
Dim strText As String

cell = 2

' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count

' Begin the loop.
For I = 1 To WS_Count

For Each shp In Worksheets(I).Shapes
On Error Resume Next
If Err.Number > 0 Then
Err.Clear
Else
strText = Me.Cells(cell, 2).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1
End If

Next

Next I

End Sub


The effect that happens now is the code runs through, but all it does is delete the content in every shape. It does not take the content I've put in column B into each shape.

 

[Marc L]

Hi,​

​

the easy way :​

​

column A : sheet name​

column B : shape name​

column C : native text​

column D : french text​

​

et voilà !​

 

[mdubs91]

Hi, @mdubs91

Try it without checking the string:

If Len(strText) > 0 Then
strText = Me.Cells(2, cell).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1
End If

And where is the French text located, in row 2 or col B?
If it's in col B then it should be:

strText = Me.Cells(cell, 2).Value

I've also tinkered with the coding and come up with:

Private Sub CommandButton2_Click()

Dim WS_Count As Integer
Dim I As Integer
Dim cell As Integer
Dim shp As Shape
Dim strText As String

cell = 2

' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count

' Begin the loop.
For I = 1 To WS_Count

For Each shp In Worksheets(I).Shapes
On Error Resume Next

strText = Me.Cells(cell, 2).Value
shp.TextFrame.Characters.Text = strText
cell = cell + 1

Next

Next I
End Sub


It runs through and replaces things with my test content, "Test 1", "Test 2", etc. but when I rerun command button 1, it clearly didn't work as expected as it wrote Test 21, to what should be the first shape, test 23 to 2 and so on....It skips over a bunch of shapes for a reason I can't identify.

 

[Marc L]

​

Well read post #4 as with this obvious logic you can't have any issue …​

​

 

[mdubs91]

Hi,​

​

the easy way :​

​

column A : sheet name​

column B : shape name​

column C : native text​

column D : french text​

​

et voilà !​

Hi Mark,

I'm all about easy, but my mind doesn't comprehend how to code this. I presume I would need to populate a listing of sheets/shapes, but is there a fast way to do this without doing it all manually?

If you could provide some coding to me that would be great, as I'm not sure where to start.

 

[Marc L]

I have a lovely worksheet that has all the text in every shape.

How this sheet was created ?​

 

[mdubs91]

How this sheet was created ?​

I inserted a new worksheet into the workbook, added command button 1 and 2 with the above coding. When I click command button 1, this new worksheet populates with the text from all shapes in the entire workbook.

 

[mdubs91]

Figured it out!

Private Sub CommandButton2_Click()



Dim WS_Count As Integer

Dim I As Integer

Dim cell As Integer

Dim shp As Shape

Dim strText As String

Dim strText2 As String





cell = 2



' Set WS_Count equal to the number of worksheets in the active

' workbook.

WS_Count = ActiveWorkbook.Worksheets.Count



' Begin the loop.

For I = 1 To WS_Count



For Each shp In Worksheets(I).Shapes

On Error Resume Next

strText2 = shp.TextFrame.Characters.Text

If Err.Number > 0 Then

Err.Clear

Else

If Len(strText2) > 0 Then

strText = Me.Cells(cell, 2).Value

shp.TextFrame.Characters.Text = strText

cell = cell + 1

End If

End If

Next



Next I

End Sub

It only copies the text though, so if anyone knows how to bring the formatting (some words in the bubbles are bolded), that would be the cherry on top. Thanks all!