Running multiple macros simultaneously but only the first macro formats the data correctly

Z

zolinaro

New Member
Joined
Nov 9, 2022
Messages
1
I have 5 macros which pull 5 images from another sheet and crops and sorts them appropriately. I have assigned all macros to a module which is then assigned to the button click to run all macros at once. The issue I am having is that when I run the macros simultaneously, all images get pulled through correctly but only the first image gets cropped. However, when I run the macros individually, they all work correctly. How can I modify my code so that all images are formatted correctly when I run the macros all at once?
Code.JPG

Module code:

VBA Code: 
Sub Button1_Click()
    Call comp1 'comp1
    Call comp2 'comp2
    Call comp3 'comp3
    Call comp4 'comp4
    Call comp5 'comp5
    
End Sub

Main code:

VBA Code: 
Sub comp1()
Dim wks As Worksheet
    Dim shp As Shape
    Dim shpNew As Shape
   
    Set wks = Sheets("PRESENTATION")
   
    If LCase(wks.Range("G1").Value) = "1" Then
        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 0")
    Else
        If LCase(wks.Range("G1").Value) = "2" Then
            Set shp = Sheets("RentComparableExpanded").Shapes("Picture 1")
        Else
            If LCase(wks.Range("G1").Value) = "3" Then
                Set shp = Sheets("RentComparableExpanded").Shapes("Picture 2")
            Else
                If LCase(wks.Range("G1").Value) = "4" Then
                    Set shp = Sheets("RentComparableExpanded").Shapes("Picture 3")
                Else
                    If LCase(wks.Range("G1").Value) = "5" Then
                        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 4")
                    Else
                              If LCase(wks.Range("G1").Value) = "6" Then
                              Set shp = Sheets("RentComparableExpanded").Shapes("Picture 6")
                            Else
                                Set shp = Sheets("RentComparableExpanded").Shapes("")
                        End If
                    End If
                End If
            End If
        End If
    End If
    
   
    shp.Copy
    wks.Paste wks.Range("G11")
    
    With Selection.ShapeRange.PictureFormat
        .CropBottom = 25
          .CropRight = 5
    End With
            

'End of Comp 1

End Sub

Sub comp2()
Dim wks As Worksheet
    Dim shp As Shape
    Dim shpNew As Shape
   
    Set wks = Sheets("PRESENTATION")
   
    If LCase(wks.Range("H1").Value) = "1" Then
        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 0")
    Else
        If LCase(wks.Range("H1").Value) = "2" Then
            Set shp = Sheets("RentComparableExpanded").Shapes("Picture 1")
        Else
            If LCase(wks.Range("H1").Value) = "3" Then
                Set shp = Sheets("RentComparableExpanded").Shapes("Picture 2")
            Else
                If LCase(wks.Range("H1").Value) = "4" Then
                    Set shp = Sheets("RentComparableExpanded").Shapes("Picture 3")
                Else
                    If LCase(wks.Range("H1").Value) = "5" Then
                        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 4")
                    Else
                              If LCase(wks.Range("H1").Value) = "6" Then
                              Set shp = Sheets("RentComparableExpanded").Shapes("Picture 6")
                            Else
                                Set shp = Sheets("RentComparableExpanded").Shapes("")
                        End If
                    End If
                End If
            End If
        End If
    End If
    
   
    shp.Copy
    wks.Paste wks.Range("H11")
    
    With Selection.ShapeRange.PictureFormat
        .CropBottom = 25
        .CropRight = 5
    End With
            

'End of Comp 2

End Sub

Sub comp3()
Dim wks As Worksheet
    Dim shp As Shape
    Dim shpNew As Shape
   
    Set wks = Sheets("PRESENTATION")
   
    If LCase(wks.Range("I1").Value) = "1" Then
        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 0")
    Else
        If LCase(wks.Range("I1").Value) = "2" Then
            Set shp = Sheets("RentComparableExpanded").Shapes("Picture 1")
        Else
            If LCase(wks.Range("I1").Value) = "3" Then
                Set shp = Sheets("RentComparableExpanded").Shapes("Picture 2")
            Else
                If LCase(wks.Range("I1").Value) = "4" Then
                    Set shp = Sheets("RentComparableExpanded").Shapes("Picture 3")
                Else
                    If LCase(wks.Range("I1").Value) = "5" Then
                        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 4")
                    Else
                              If LCase(wks.Range("I1").Value) = "6" Then
                              Set shp = Sheets("RentComparableExpanded").Shapes("Picture 6")
                            Else
                                Set shp = Sheets("RentComparableExpanded").Shapes("")
                        End If
                    End If
                End If
            End If
        End If
    End If
    
   
    shp.Copy
    wks.Paste wks.Range("I11")
    
    With Selection.ShapeRange.PictureFormat
        .CropBottom = 25
        .CropRight = 5
    End With
            

'End of Comp 3

End Sub

Sub comp4()
Dim wks As Worksheet
    Dim shp As Shape
    Dim shpNew As Shape
   
    Set wks = Sheets("PRESENTATION")
   
    If LCase(wks.Range("J1").Value) = "1" Then
        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 0")
    Else
        If LCase(wks.Range("J1").Value) = "2" Then
            Set shp = Sheets("RentComparableExpanded").Shapes("Picture 1")
        Else
            If LCase(wks.Range("J1").Value) = "3" Then
                Set shp = Sheets("RentComparableExpanded").Shapes("Picture 2")
            Else
                If LCase(wks.Range("J1").Value) = "4" Then
                    Set shp = Sheets("RentComparableExpanded").Shapes("Picture 3")
                Else
                    If LCase(wks.Range("J1").Value) = "5" Then
                        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 4")
                    Else
                              If LCase(wks.Range("J1").Value) = "6" Then
                              Set shp = Sheets("RentComparableExpanded").Shapes("Picture 6")
                            Else
                                Set shp = Sheets("RentComparableExpanded").Shapes("")
                        End If
                    End If
                End If
            End If
        End If
    End If
    
   
    shp.Copy
    wks.Paste wks.Range("J11")
    
    With Selection.ShapeRange.PictureFormat
        .CropBottom = 25
        .CropRight = 5
    End With
            

'End of Comp 4

End Sub

Sub comp5()
Dim wks As Worksheet
    Dim shp As Shape
    Dim shpNew As Shape
   
    Set wks = Sheets("PRESENTATION")
   
    If LCase(wks.Range("K1").Value) = "1" Then
        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 0")
    Else
        If LCase(wks.Range("K1").Value) = "2" Then
            Set shp = Sheets("RentComparableExpanded").Shapes("Picture 1")
        Else
            If LCase(wks.Range("K1").Value) = "3" Then
                Set shp = Sheets("RentComparableExpanded").Shapes("Picture 2")
            Else
                If LCase(wks.Range("K1").Value) = "4" Then
                    Set shp = Sheets("RentComparableExpanded").Shapes("Picture 3")
                Else
                    If LCase(wks.Range("K1").Value) = "5" Then
                        Set shp = Sheets("RentComparableExpanded").Shapes("Picture 4")
                    Else
                              If LCase(wks.Range("K1").Value) = "6" Then
                              Set shp = Sheets("RentComparableExpanded").Shapes("Picture 6")
                            Else
                                Set shp = Sheets("RentComparableExpanded").Shapes("")
                        End If
                    End If
                End If
            End If
        End If
    End If
    
   
    shp.Copy
    wks.Paste wks.Range("K11")
    
    With Selection.ShapeRange.PictureFormat
        .CropBottom = 25
        .CropRight = 5
    End With
            

'End of Comp 5

End Sub
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.
Sort by date Sort by votes
Hi zolinaro and Welcome to the Board. I suspect XL needs time to do it's thing. Trial placing this code after each macro call.
Code: 
Sub WaitAbit()
Dim t As Double
t = Timer
Do Until Timer - t > 1
  DoEvents
Loop
End Sub
So...
Code: 
Call comp1 
Call WaitAbit
Call comp2 
Call WaitAbit
Call comp3 
'etc
HTH. Thanks to Jon Peltier for that bit of code. Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
269
offthelip
O
C
  • Question
Insert picture using VBA throws up an error
Replies
9
Views
869
chriscorpion786
C
KlausW
  • Solved
Run macro when enter "Enter" key
2
Replies
16
Views
932
Candyman8019
C
P
  • Solved
Copying data from multiple sheets with VBA
2
Replies
16
Views
921
smozgur
smozgur
W
  • Question
Run Time Error 1004 Excel cannot paste the data
Replies
8
Views
903
Fluff
Fluff

Forum statistics

Threads
1,214,591
Messages
6,120,427
Members
448,961
Latest member
nzskater

Share this page

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