Run Time Error 1004 Excel cannot paste the data

wasif85

New Member
Joined
Jan 9, 2022
Messages
4
Office Version
  1. 365
Platform
  1. Windows
Hi All

My Macro copy picture from sheet2 & paste it into Sheet1 with conditions. My Macro perform smooth in debug mode but as i run it by pressing F5 key, it prompt error at different address every time. I have tried the do events as well but still facing the issue.
Kindly address the issues and complete coding is given below.

Dim ab, str As String, a, c, counter As Long, sh As Shape
Set sh = Sheet1.Shapes(1)
For Each sh In Sheet1.Shapes
sh.Delete
Next
a = 5
Do Until IsEmpty(Sheet1.Cells(a, 2).Value)
c = 5
str = Sheet1.Cells(a, 4).Value
For counter = 1 To Len(str)
ab = Mid(str, counter, 1)
If ab = "0" Then
Sheet2.Shapes(1).Copy
doevents
Sheet1.Cells(a, c).Select
ActiveSheet.Pictures.Paste
Else
Sheet2.Shapes(1).Copy
doevents
Sheet1.Cells(a, c).Select
ActiveSheet.Pictures.Paste
End If
c = c + 1
Next
a = a + 1
Loop
 

Attachments

  • 1.png
    1.png
    102.5 KB · Views: 12
  • 2.png
    2.png
    98.1 KB · Views: 11

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Doevents was a good trial, but still not enough sometimes.
That's why you get an unregular error.
You can start by taking a pause of 1 sec with application.wait.
Otherwise, is this macro runs often, then you can reduce it to 200-500 msec. (you have to add references in the VBA-editor and ...)
 
Upvote 0
Doevents was a good trial, but still not enough sometimes.
That's why you get an unregular error.
You can start by taking a pause of 1 sec with application.wait.
Otherwise, is this macro runs often, then you can reduce it to 200-500 msec. (you have to add references in the VBA-editor and ...)
Another issue is it is taking too long. My data consist of 2048 rows with 8 columns & Macros takes almost 10 minutes to complete. I am in stone age.
with application.wait, it still give same error
 
Upvote 0
10 minutes, what do you have to calculate, a journey to the moon ?
 
Upvote 0
VBA Code:
Sub xxx()

     Dim ab, str As String, a, c, counter As Long, sh As Shape
     Set sh = Sheet1.Shapes(1)
     For Each sh In Sheet1.Shapes
          sh.Delete
     Next
     a = 5
     Do Until IsEmpty(Sheet1.Cells(a, 2).Value)
          c = 5
          str = Sheet1.Cells(a, 4).Value
          For counter = 1 To Len(str)
               ab = Mid(str, counter, 1)
               If ab = "0" Then
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               Else
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               End If
               c = c + 1
          Next
          a = a + 1
     Loop

End Sub

Sub Waiting()
     '************************************
     'this macro delays execution with .250 mseconds
     '************************************

     mydelay = 0.25                                             '250 msec delay
     mytime = Now + (Timer - Int(Timer) + mydelay) / 86400
     Do
          DoEvents
     Loop While Now + (Timer - Int(Timer)) / 86400 < mytime
End Sub
 
Upvote 0
10 minutes, what do you have to calculate, a journey to the moon ?
let me share you the complete file.
VBA Code:
Sub xxx()

     Dim ab, str As String, a, c, counter As Long, sh As Shape
     Set sh = Sheet1.Shapes(1)
     For Each sh In Sheet1.Shapes
          sh.Delete
     Next
     a = 5
     Do Until IsEmpty(Sheet1.Cells(a, 2).Value)
          c = 5
          str = Sheet1.Cells(a, 4).Value
          For counter = 1 To Len(str)
               ab = Mid(str, counter, 1)
               If ab = "0" Then
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               Else
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               End If
               c = c + 1
          Next
          a = a + 1
     Loop

End Sub

Sub Waiting()
     '************************************
     'this macro delays execution with .250 mseconds
     '************************************

     mydelay = 0.25                                             '250 msec delay
     mytime = Now + (Timer - Int(Timer) + mydelay) / 86400
     Do
          DoEvents
     Loop While Now + (Timer - Int(Timer)) / 86400 < mytime
End Sub
Thanks for the support. Kindly find the attached sheet and as i run add shapes Macro, it take almost 30 minutes
 
Upvote 0
you can send me the complete file, if you like ... .
 
Upvote 0
VBA Code:
Sub xxx()

     Dim ab, str As String, a, c, counter As Long, sh As Shape
     Set sh = Sheet1.Shapes(1)
     For Each sh In Sheet1.Shapes
          sh.Delete
     Next
     a = 5
     Do Until IsEmpty(Sheet1.Cells(a, 2).Value)
          c = 5
          str = Sheet1.Cells(a, 4).Value
          For counter = 1 To Len(str)
               ab = Mid(str, counter, 1)
               If ab = "0" Then
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               Else
                    Sheet2.Shapes(1).Copy
                    Waiting
                    Sheet1.Cells(a, c).Select
                    ActiveSheet.Pictures.Paste
                    Waiting
               End If
               c = c + 1
          Next
          a = a + 1
     Loop

End Sub

Sub Waiting()
     '************************************
     'this macro delays execution with .250 mseconds
     '************************************

     mydelay = 0.25                                             '250 msec delay
     mytime = Now + (Timer - Int(Timer) + mydelay) / 86400
     Do
          DoEvents
     Loop While Now + (Timer - Int(Timer)) / 86400 < mytime
End Sub

you can send me the complete file, if you like ... .
 
Upvote 0
you can send me the complete file, if you like ... .
Please do not ask members to send you files. All communication must remain on the board including links to files.
let me share you the complete file.
If you want to share a file you need to upload it to a share site such as OneDrive, DropBox, Google Drive & mark for sharing. Then post the link you are given to the thread.
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top