macro-copy pictures from comments in a column then paste to another column

[b90702098]

hi all,
In my worksheet,
column B contained comments with pictures.
I wish to extract the pictures in comments and paste the picture to corresponding column C
(i.e. copy the picture contained in the comment of cell B2 and paste the picture to cell C2)

My current macro:
Sub Macro1()
Dim rngTemp As Range
Set rngTemp = ActiveCell
Application.ScreenUpdating = False
With ActiveCell
.Comment.Visible = True
.Comment.Shape.Select
.Comment.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
.Comment.Visible = False
End With
ActiveSheet.Range("A1").PasteSpecial
Application.ScreenUpdating = True
End Sub



however it can only deal with one cell and I need to move the cursor to each cell that has comments.

Much appreciated if anyone could fix my code?
I imagine that a simple loop function would do but couldnt come up with one...

thanks

[Kenneth Hobs]

Welcome to the forum!

Sub Macro1()
Dim c As Comment

Application.ScreenUpdating = False

For Each c In ActiveSheet.Comments
With c
If .Parent.Column <> 2 Then GoTo NextC
.Visible = True
.Shape.Select
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
.Visible = False
.Parent.Offset(0, 1).PasteSpecial
End With
NextC:
Next c

Application.ScreenUpdating = True
Range("A1").Select
End Sub

[b90702098]

Thanks Kenneth.
After pasting..I was thinking to resize them to the same size.
so I had code as below-

Sub Macro1()
Dim c As Comment

Application.ScreenUpdating = False

For Each c In ActiveSheet.Comments
With c
If .Parent.Column <> 2 Then GoTo NextC
.Visible = True
.Shape.Select
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
.Visible = False
.Parent.Offset(0, 1).PasteSpecial.Select
With Selection
'.Left = Range("A6").Left
'.Top = Range("A6").Top
.Left = Cells(pasteAt, 1).Left
.Top = Cells(pasteAt, 1).Top

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 80#
.ShapeRange.Rotation = 0#
End With

End With
NextC:
Next c

Application.ScreenUpdating = True
Range("A1").Select
End Sub

However an error occurred-run time 424. an object is required.
Anyway that I can solve this?

Much appreciated and sorry for the late reply.

[Kenneth Hobs]

The reason for the object error is that there is no Select method for PasteSpecial.

Another problem is that you have not defined pasteAt. I recommend using Option Explicit as the first line of code in a Module.

Sub Macro2()
Dim c As Comment, r As Range

Application.ScreenUpdating = False

For Each c In ActiveSheet.Comments
With c
If .Parent.Column <> 4 Then GoTo NextC
.Visible = True
.Shape.Select
.Shape.CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
.Visible = False
Set r = .Parent.Offset(0, 1)
r.PasteSpecial
With Selection
.Top = r.Top
.Left = r.Left
.Height = 180#
.Width = 80#
End With
End With
NextC:
Next c

Application.ScreenUpdating = True
Range("A1").Select
End Sub

[b90702098]

Thanks Kennth.
The code you posted didn't work but if I modify If .Parent.Column <> 4 to If .Parent.Column <> 2 then it works...not sure why though..lol

Again, much appreciated your patience and help!

[Kenneth Hobs]

The code worked but did not do what you expected. In my tests, I put the commented cells into column D rather than your column B. I sometimes forget to change those sorts of things back in my rush to sleepy time...

cheers