VBA code to copy row with image into new worksheet

[ss2390]

I found some code online that works to copy a checked box row into a new worksheet, but it doesn't copy the picture that it is the row. How can I modify the code to get the image to transfer as well?

My current macro is below:

Sub CopyRows()
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = 1 Then
For r = 1 To Rows.Count
If Cells(r, 1).Top = chkbx.Top Then
With Worksheets("Selected_Chemicals")
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & LRow & ":G" & LRow) = _
ActiveSheet.Range("A" & r & ":G" & r).Value
End With
Exit For
End If
Next r
End If
Next
End Sub

Thanks for the help

 

[pbornemeier]

Is each picture is contained entirely within a row?
Is there only 1 picture in each row?
Would it be possible to use a column in the worksheet to hold the name of the picture?

If all of the above is true then this might help:

If the shape is contained entirely within a row then this code will append the row the shape is in to the shape name and add that name to a specified column. Any shapes not contained in a single row will be listed on a separate worksheet

Sub NameShapesByLocation()
    'Append the row number of the picture to the name of any picture contained in a single row.
    'Create a list of pictures that occupy more than one row
    'Add the picture name to a sPictureNameColumn in the data
    
    Dim shp As Shape
    Dim lPictureRow As Long
    Dim lNextWriteRow As Long
    Dim sActiveSheet As String
    Dim lDividerPos As Long
    
    Const sWorksheet As String = "Problem Pictures"
    Const sPictureNameColumn As String = "H"
    
    sActiveSheet = "Selected_Chemicals"
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
    Worksheets(sWorksheet).Range("A1").Resize(1, 3).Value = Array("Name", "UL Address", "LR Address")
    lNextWriteRow = 1
    
    For Each shp In Worksheets(sActiveSheet).Shapes
        lDividerPos = InStr(shp.Name, "__")
        If lDividerPos > 0 Then
            'Remove any previous name add on
            shp.Name = Left(shp.Name, lDividerPos - 1)
        End If
        
        Debug.Print shp.Name
        If shp.TopLeftCell.Row = shp.BottomRightCell.Row Then
            
            lPictureRow = shp.TopLeftCell.Row
            shp.Name = shp.Name & "__" & lPictureRow
            Worksheets(sActiveSheet).Range(sPictureNameColumn & lPictureRow).Value = shp.Name
        Else
            lNextWriteRow = lNextWriteRow + 1
            Worksheets(sWorksheet).Cells(lNextWriteRow, 1).Value = shp.Name
            Worksheets(sWorksheet).Cells(lNextWriteRow, 2).Value = shp.TopLeftCell.Address
            Worksheets(sWorksheet).Cells(lNextWriteRow, 3).Value = shp.BottomRightCell.Address
        End If
    Next

End Sub

The above code could also be adapted to name each of the checkboxes (chk1...chk47) so that you would not have to check each row each time for each checkbox.

Modification of your code to move the picture will be provided later,

 

[Worf]

Another example; if you have a lot of check boxes and pictures, it can be rewritten with less looping...

Sub CopyRows()
Dim chkbx As OLEObject, r%, lrow%, a, b$, sh As Shape, cs As Worksheet
Set cs = Worksheets("Selected_Chemicals")
a = Split(ActiveSheet.UsedRange.Address, "$")
' ActiveX checkboxes
For Each chkbx In ActiveSheet.OLEObjects
    If chkbx.Object.Value And InStr(chkbx.Name, "Check") > 0 Then
        For r = WorksheetFunction.Substitute(a(2), ":", "") To a(UBound(a)) ' only used range
            If r = chkbx.TopLeftCell.Row Then
                With cs
                    lrow = .Range("A" & Rows.Count).End(xlUp).Row + 1
                    .Range("A" & lrow & ":G" & lrow).Value = ActiveSheet.Range("A" & r & ":G" & r).Value
                End With
                For Each sh In ActiveSheet.Shapes
                    If sh.TopLeftCell.Row = r And InStr(sh.Name, "Picture") > 0 Then
                        sh.Copy
                        cs.Paste
                        cs.Shapes(cs.Shapes.Count).Top = Cells(lrow, 1).Top 'position picture
                        cs.Shapes(cs.Shapes.Count).Left = Cells(1, 8).Left
                        Exit For
                    End If
                 Next
                Exit For
            End If
        Next r
    End If
Next
End Sub

 

[ss2390]

Thanks Phil,

To answer all of your above questions, yes, they are all true. Here's a snapshot of what the sheet looks like:


-- removed inline image ---


I basically want the macro to copy the exact content and layout of the row into a new sheet.

I added the code you sent into a new module, selected one of the rows and ran the new module, but the only output it gave was to create the following:


-- removed inline image ---


Thanks again for the help,
Scott

 

[Worf]

Hi Scott
1) I got broken links on your snapshots.
2) I understand you are using form controls, could you run this code to confirm that? Then I can rewrite my code. How many check boxes do you have on the worksheet? What Excel version are you using?

Sub AnalyzeShapes()
Dim sh As Shape, st(1 To 8), i%, s$, n
n = Array("Auto shapes", "Charts", "Forms", "Lines", "OLE controls", _
"Pictures", "Tables", "Other shapes")
For i = 1 To 8
    st(i) = 0
Next
s = ""
For Each sh In ActiveSheet.Shapes
    Select Case sh.Type
        Case msoAutoShape:                  st(1) = st(1) + 1
        Case msoChart:                      st(2) = st(2) + 1
        Case msoFormControl:                st(3) = st(3) + 1
        Case msoLine:                       st(4) = st(4) + 1
        Case msoOLEControlObject:           st(5) = st(5) + 1
        Case msoPicture:                    st(6) = st(6) + 1
        Case msoTable:                      st(7) = st(7) + 1
        Case Else:                          st(8) = st(8) + 1
    End Select
Next
For i = 1 To 8
    s = s & st(i) & " " & n(i - 1) & vbLf
Next
MsgBox s, vbInformation, ActiveSheet.Name
End Sub


Sub Forms_and_OLEs()
Dim sh As Shape ' displays individual message for each control


For Each sh In ActiveSheet.Shapes
    Select Case sh.Type
        Case msoFormControl
            MsgBox sh.Name, vbInformation, "Form"
        Case msoOLEControlObject
            MsgBox sh.Name, vbInformation, "OLE"
    End Select
Next
End Sub