Worksheet_Change event doesn't trigger when using paste values

S

spprtpplcm

New Member
Joined
Dec 5, 2022
Messages
5
Office Version
  1. 2013
Platform
  1. Windows
Hey,

I have this VBA code that works as a Vlookup with images. However, it only works when I manually enter data in the cell. When pasting values of a whole range of data (or even a single cell value), the Vba code doesn't trigger. Kindly help. I am not much experienced in VBA, and I got this code from stackoverflow, so it's really hard to figure out.

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim wsM As Worksheet, wsOf As Worksheet, sh As Shape, shp As Shape, strSKU As String
    Dim sHeight As Double, sWidth As Double, rngProduct As Range, i As Long
    
    On Error Resume Next
    If Target.Value = "" Then Exit Sub
    If Target.Column = 1 Then
        If Target.Cells.Count > 1 Then MsgBox "This code works only for a single cell (in column A:A) modification)!": Exit Sub
        Set wsM = Worksheets("Sheet1")  'use here your master sheet
        Set wsOf = Me                   'the active sheet (this one)
        'find the product code introduced in the offer sheet:
        Set rngProduct = wsM.Range("A:A").Find(What:=Target.Value, After:=wsM.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole)
        If rngProduct Is Nothing Then MsgBox "No product """ & Target.Value & """ found in the master sheet": Exit Sub
        
        'Copy the fields brought until now using Vlookup:
        Application.EnableEvents = False
         For i = 2 To 21 'it copies the next three columns after B:B. If more columns necessary to be copied, increas from 4 to  necessary
              Target.Offset(, i).Value = rngProduct.Offset(, i).Value
         Next i
        Application.EnableEvents = True
        
        'format C:C column as text (even aleready having numbers formatted as scientifique:
        Me.UsedRange.Columns(3).EntireColumn.TextToColumns FieldInfo:=Array(1, 2)

        For Each sh In wsM.Shapes 'iterate between master sheet shapes:
             If TypeName(sh.OLEFormat.Object) = "Picture" And sh.Name = Target.Value Then 'if its name is the searched SKU and is a Picture
                     sh.Copy:                     'copy  the necessary shape
                    Application.Wait Now + TimeValue("00:00:01")
                    wsOf.Paste
                    Set shp = wsOf.Shapes(wsOf.Shapes.Count) 'set the last copied/created shape
                                      
                     sHeight = shp.Height: sWidth = shp.Width 'extract initial height and width
                    
                     'determine which dimension should be diminished, to be sure that both of them are inside the cell:
                     If shp.Height < Target.Offset(, 1).Height And shp.Width < Target.Offset(, 1).Width Then
                                If shp.Height > shp.Width Then
                                  shp.Height = Target.Offset(, 1).Height - 2
                                  If shp.Width > Target.Offset(, 1).Width Then shp.Width = Target.Offset(, 1).Width
                                  sWidth = shp.Width: sHeight = shp.Height
                            Else
                                 shp.Width = Target.Offset(, 1).Width - 2
                                 If shp.Height > Target.Offset(, 1).Height Then shp.Height = Target.Offset(, 1).Height
                                 sWidth = shp.Width: sHeight = shp.Height
                            End If
                     ElseIf shp.Height < Target.Offset(, 1).Height And shp.Width > Target.Offset(, 1).Width Then
                               shp.Width = Target.Offset(, 1).Width - 2: sWidth = shp.Width: sHeight = shp.Height:: sWidth = shp.Width
                     ElseIf shp.Height > Target.Offset(, 1).Height And shp.Width > Target.Offset(, 1).Width Then
                            If shp.Height > shp.Width Then
                                  shp.Height = Target.Offset(, 1).Height - 2
                                  If shp.Width > Target.Offset(, 1).Width Then shp.Width = Target.Offset(, 1).Width
                                  sWidth = shp.Width: sHeight = shp.Height
                            Else
                                 shp.Width = Target.Offset(, 1).Width - 2:
                                 If shp.Height > Target.Offset(, 1).Height Then shp.Height = Target.Offset(, 1).Height
                                 sWidth = shp.Width: sHeight = shp.Height
                            End If
                     End If
                    
                     'set the correct top and left, to be centered on cell:
                      shp.Top = Target.Offset(, 1).Top + (Target.Offset(, 1).Height - sHeight) / 2
                      shp.Left = Target.Offset(, 1).Left + Target.Offset(, 1) + (Target.Offset(, 1).Width - sWidth) / 2
                     Exit For
             End If
        Next sh
    End If

End Sub

Excel version - Microsoft Office Professional Plus 2013
OS - Windows 11 Home
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sort by date Sort by votes
That macro is a bit of a hot mess. When you see an On Error Resume Next statement as the very first statement right after variable declarations, it is never a good sign. The code does execute if you paste, but errors out which is being hidden from you by the On Error Resume Next statement so that it only seems like it does not trigger.

Anyway, the code specifically says it won't work if you modify more that one cell at a time:
VBA Code: 
MsgBox "This code works only for a single cell (in column A:A) modification)!": Exit Sub

Pasting just one cell will work, if the value does not trigger an error. You can see for yourself by removing the On Error Resume Next statement.
 
Upvote 0
rlv01 said:
That macro is a bit of a hot mess. When you see an On Error Resume Next statement as the very first statement right after variable declarations, it is never a good sign. The code does execute if you paste, but errors out which is being hidden from you by the On Error Resume Next statement so that it only seems like it does not trigger.

Anyway, the code specifically says it won't work if you modify more that one cell at a time:
VBA Code: 
MsgBox "This code works only for a single cell (in column A:A) modification)!": Exit Sub

Pasting just one cell will work, if the value does not trigger an error. You can see for yourself by removing the On Error Resume Next statement.
Click to expand...
The On Error Resume Next code was added by me purposely, cuz it always shows an error whenever I paste multiple values on (A:A), delete multiple values on (A:A) or any other range of cells, so I just added this code to not show any errors. If I remove this code and execute by pasting multiple cell values, then I get a run-time error'13' Type mismatch and clicking on debug leads to the forth line of the VBA code If Target.Value = "" Then Exit Sub.
Anyway, the code specifically says it won't work if you modify more that one cell at a time:
Click to expand...

I understand, but is there any workaround for this? I also made a small video so you will get an idea how it works for now. Right-now, I removed the On Error Resume Next code and you can see it shows the same error, whenever I paste multiple cell values on (A:A) or delete multiple cell values. Link to video (imgur).
 
Upvote 0
You could end up with a lot of message boxes popping up if you paste a lot of values. I suspect that would be quite annoying...
 
Upvote 0
RoryA said:
You could end up with a lot of message boxes popping up if you paste a lot of values. I suspect that would be quite annoying...
Click to expand...
But it would work right? If it works and the 'message boxes popping' is the only problem, then I guess it could be solved by disabling all message pop-ups in vba?
 
Upvote 0
Yes. Untested, but something like:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
   Dim wsM As Worksheet, wsOf As Worksheet, sh As Shape, shp As Shape, strSKU As String
   Dim sHeight As Double, sWidth As Double, rngProduct As Range, i As Long
   
   If Not Intersect(Target, Range("A:A")) Is Nothing Then
      Set wsM = Worksheets("Sheet1")  'use here your master sheet
      Set wsOf = Me                   'the active sheet (this one)
      Dim cell As Range
      For Each cell In Intersect(Target, Range("A:A")).Cells
         If Len(cell.Value) <> 0 Then
            'find the product code introduced in the offer sheet:
            Set rngProduct = wsM.Range("A:A").Find(What:=cell.Value, After:=wsM.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rngProduct Is Nothing Then
            
               'Copy the fields brought until now using Vlookup:
               Application.EnableEvents = False
               For i = 2 To 21 'it copies the next three columns after B:B. If more columns necessary to be copied, increas from 4 to  necessary
                  cell.Offset(, i).Value = rngProduct.Offset(, i).Value
               Next i
               Application.EnableEvents = True
               
               'format C:C column as text (even aleready having numbers formatted as scientifique:
               Me.UsedRange.Columns(3).EntireColumn.TextToColumns FieldInfo:=Array(1, 2)
               
               For Each sh In wsM.Shapes 'iterate between master sheet shapes:
                  If TypeName(sh.OLEFormat.Object) = "Picture" And sh.Name = cell.Value Then 'if its name is the searched SKU and is a Picture
                     sh.Copy:                     'copy  the necessary shape
                     Application.Wait Now + TimeValue("00:00:01")
                     wsOf.Paste
                     Set shp = wsOf.Shapes(wsOf.Shapes.Count) 'set the last copied/created shape
                     
                     sHeight = shp.Height: sWidth = shp.Width 'extract initial height and width
                     
                     'determine which dimension should be diminished, to be sure that both of them are inside the cell:
                     If shp.Height < cell.Offset(, 1).Height And shp.Width < cell.Offset(, 1).Width Then
                        If shp.Height > shp.Width Then
                           shp.Height = cell.Offset(, 1).Height - 2
                           If shp.Width > cell.Offset(, 1).Width Then shp.Width = cell.Offset(, 1).Width
                        sWidth = shp.Width: sHeight = shp.Height
                        Else
                           shp.Width = cell.Offset(, 1).Width - 2
                           If shp.Height > cell.Offset(, 1).Height Then shp.Height = cell.Offset(, 1).Height
                           sWidth = shp.Width: sHeight = shp.Height
                        End If
                     ElseIf shp.Height < cell.Offset(, 1).Height And shp.Width > cell.Offset(, 1).Width Then
                           shp.Width = cell.Offset(, 1).Width - 2: sWidth = shp.Width: sHeight = shp.Height:: sWidth = shp.Width
                     ElseIf shp.Height > cell.Offset(, 1).Height And shp.Width > cell.Offset(, 1).Width Then
                        If shp.Height > shp.Width Then
                           shp.Height = cell.Offset(, 1).Height - 2
                           If shp.Width > cell.Offset(, 1).Width Then shp.Width = cell.Offset(, 1).Width
                           sWidth = shp.Width: sHeight = shp.Height
                        Else
                           shp.Width = cell.Offset(, 1).Width - 2:
                           If shp.Height > cell.Offset(, 1).Height Then shp.Height = cell.Offset(, 1).Height
                           sWidth = shp.Width: sHeight = shp.Height
                        End If
                     End If
                     
                     'set the correct top and left, to be centered on cell:
                     shp.Top = cell.Offset(, 1).Top + (cell.Offset(, 1).Height - sHeight) / 2
                     shp.Left = cell.Offset(, 1).Left + cell.Offset(, 1) + (cell.Offset(, 1).Width - sWidth) / 2
                     Exit For
                  End If
               Next sh
            End If
         End If
      Next cell
   End If
End Sub
 
Upvote 0
Solution
RoryA said:
Yes. Untested, but something like:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
   
   Dim wsM As Worksheet, wsOf As Worksheet, sh As Shape, shp As Shape, strSKU As String
   Dim sHeight As Double, sWidth As Double, rngProduct As Range, i As Long
  
   If Not Intersect(Target, Range("A:A")) Is Nothing Then
      Set wsM = Worksheets("Sheet1")  'use here your master sheet
      Set wsOf = Me                   'the active sheet (this one)
      Dim cell As Range
      For Each cell In Intersect(Target, Range("A:A")).Cells
         If Len(cell.Value) <> 0 Then
            'find the product code introduced in the offer sheet:
            Set rngProduct = wsM.Range("A:A").Find(What:=cell.Value, After:=wsM.Range("A1"), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rngProduct Is Nothing Then
           
               'Copy the fields brought until now using Vlookup:
               Application.EnableEvents = False
               For i = 2 To 21 'it copies the next three columns after B:B. If more columns necessary to be copied, increas from 4 to  necessary
                  cell.Offset(, i).Value = rngProduct.Offset(, i).Value
               Next i
               Application.EnableEvents = True
              
               'format C:C column as text (even aleready having numbers formatted as scientifique:
               Me.UsedRange.Columns(3).EntireColumn.TextToColumns FieldInfo:=Array(1, 2)
              
               For Each sh In wsM.Shapes 'iterate between master sheet shapes:
                  If TypeName(sh.OLEFormat.Object) = "Picture" And sh.Name = cell.Value Then 'if its name is the searched SKU and is a Picture
                     sh.Copy:                     'copy  the necessary shape
                     Application.Wait Now + TimeValue("00:00:01")
                     wsOf.Paste
                     Set shp = wsOf.Shapes(wsOf.Shapes.Count) 'set the last copied/created shape
                    
                     sHeight = shp.Height: sWidth = shp.Width 'extract initial height and width
                    
                     'determine which dimension should be diminished, to be sure that both of them are inside the cell:
                     If shp.Height < cell.Offset(, 1).Height And shp.Width < cell.Offset(, 1).Width Then
                        If shp.Height > shp.Width Then
                           shp.Height = cell.Offset(, 1).Height - 2
                           If shp.Width > cell.Offset(, 1).Width Then shp.Width = cell.Offset(, 1).Width
                        sWidth = shp.Width: sHeight = shp.Height
                        Else
                           shp.Width = cell.Offset(, 1).Width - 2
                           If shp.Height > cell.Offset(, 1).Height Then shp.Height = cell.Offset(, 1).Height
                           sWidth = shp.Width: sHeight = shp.Height
                        End If
                     ElseIf shp.Height < cell.Offset(, 1).Height And shp.Width > cell.Offset(, 1).Width Then
                           shp.Width = cell.Offset(, 1).Width - 2: sWidth = shp.Width: sHeight = shp.Height:: sWidth = shp.Width
                     ElseIf shp.Height > cell.Offset(, 1).Height And shp.Width > cell.Offset(, 1).Width Then
                        If shp.Height > shp.Width Then
                           shp.Height = cell.Offset(, 1).Height - 2
                           If shp.Width > cell.Offset(, 1).Width Then shp.Width = cell.Offset(, 1).Width
                           sWidth = shp.Width: sHeight = shp.Height
                        Else
                           shp.Width = cell.Offset(, 1).Width - 2:
                           If shp.Height > cell.Offset(, 1).Height Then shp.Height = cell.Offset(, 1).Height
                           sWidth = shp.Width: sHeight = shp.Height
                        End If
                     End If
                    
                     'set the correct top and left, to be centered on cell:
                     shp.Top = cell.Offset(, 1).Top + (cell.Offset(, 1).Height - sHeight) / 2
                     shp.Left = cell.Offset(, 1).Left + cell.Offset(, 1) + (cell.Offset(, 1).Width - sWidth) / 2
                     Exit For
                  End If
               Next sh
            End If
         End If
      Next cell
   End If
End Sub
Click to expand...
Wow!! This works perfectly!! Thank you so much.
I have one more small request. Is there any way for the vba to copy the rows formatting (including the row size) to the other rows below, wherever the cell value is present on (A:A)? For example, if you have seen my video I posted before, the formatting was only till Row 6, so if have a range that's more than that, and I paste that in (A:A), so will it be able to copy the formatting to all the rows wherever the value at (A:A) is present and then the vlookup runs? The reason why the formatting should be done first before vlookup is because the image will be fitted in the cell according to the cells initial size. I hope you get my point.
 
Upvote 0
spprtpplcm said:
Wow!! This works perfectly!! Thank you so much.
I have one more small request. Is there any way for the vba to copy the rows formatting (including the row size) to the other rows below, wherever the cell value is present on (A:A)? For example, if you have seen my video I posted before, the formatting was only till Row 6, so if have a range that's more than that, and I paste that in (A:A), so will it be able to copy the formatting to all the rows wherever the value at (A:A) is present and then the vlookup runs? The reason why the formatting should be done first before vlookup is because the image will be fitted in the cell according to the cells initial size. I hope you get my point.
Click to expand...
Nevermind, I figured it out. In case, anyone want's the code for this -
VBA Code: 
 Application.EnableEvents = False
   If Not Intersect(Target, Range("A:A")) Is Nothing Then
      Dim LR As Long
    LR = Range("A1000").End(xlUp).Row

    Range("A3").Rows("1:1").EntireRow.Select
    Selection.Copy
    
    Range("A3:A" & LR).Rows.EntireRow.Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
                
    End If
                
    Application.EnableEvents = True


Thanks a lot!
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Filling Modules in a Trapezoid Shape Using Excel VBA
Replies
1
Views
212
Fluff
Fluff
I
  • Question Question
Could you check my code please
Replies
5
Views
1K
JoeMo
J
I
  • Question Question
Run time error 1004, Application defined or object defined error
2
Replies
10
Views
3K
ipbr21054
I
A
  • Question Question
Wrap Square Image when exporting Outlook
Replies
0
Views
721
aayaanmayank
A
S
  • Question Question
Capture Multiple Cell change
Replies
4
Views
876
AlphaFrog
AlphaFrog

Forum statistics

Threads
1,223,162
Messages
6,170,431
Members
452,326
Latest member
johnshaji

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