Copy selected rows data and pictures to another worksheet

Hi Piranhao,

Welcome to the Forum!

Attach a sample workbook. Make sure there is just enough data to demonstrate your need. Include a BEFORE sheet and an AFTER sheet in the workbook if needed to show the process you're trying to complete or automate. Make sure your desired results are shown, mock them up manually if necessary.

Remember to desensitize the data.

Click on GO ADVANCED and use the paperclip icon to open the upload window.

View Pic

BTW - Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

Hi Piranhao,

This works

Sub CopyExercises(): Dim w1 As Worksheet, w2 As Worksheet, r As Long, lRow As Long 'Piranhao
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
For Each chkbx In w1.CheckBoxes
    If chkbx.value = 1 Then
        For r = 1 To Rows.Count
            If Cells(r, 1).Top = chkbx.Top Then
                
                    lRow = w2.Range("A" & Rows.Count).End(xlUp).Row + 1
                    w2.Range("A" & lRow & ":I" & lRow).RowHeight = _
                    w1.Range("A" & r & ":I" & r).RowHeight
                    w1.Range("A" & r & ":I" & r).copy _
                    w2.Range("A" & lRow & ":I" & lRow)
                    
                Exit For
            End If
        Next r
    End If
Next

End Sub

You're welcome and thanks for the rep!

Hi Piranhao,

These may be what you want:

Sub CopyExercises(): Dim w1 As Worksheet, w2 As Worksheet, R As Long, lRow As Long 'Piranhao
Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
For Each chkbx In w1.CheckBoxes
    If chkbx.Value = 1 Then
        For R = 1 To Rows.Count
            If Cells(R, 1).Top = chkbx.Top Then
                
                    lRow = w2.Range("A" & Rows.Count).End(xlUp).row + 1
                    w2.Range("A" & lRow & ":I" & lRow).RowHeight = _
                    w1.Range("A" & R & ":I" & R).RowHeight
                    
            w1.Range("B" & R).Copy w2.Range("B" & lRow)
            w1.Range("H" & R).Copy w2.Range("H" & lRow)
            w1.Range("I" & R).Copy w2.Range("I" & lRow)
                    
                Exit For
            End If
        Next R
    End If
Next

End Sub

For the clear you'll need to have the row selected.

Sub ClearRowRange(): Dim R As Range, Pic As Object
Set R = Rows(ActiveCell.row)
R.ClearContents
For Each Pic In ActiveSheet.Shapes
Pic.Select
If Abs(Pic.Top - R.Top) < R.Height Then
Pic.Delete
End If: Next
End Sub

Hi Piranhao,

I had to change the code:Piranhao2.xlsm

Sub SelectExercise()
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("ExerciseInventory"): Set w2 = Sheets("ClientExerciseList")
For Each chkbx In w1.CheckBoxes
    If chkbx.Value = 1 Then
        For R = 12 To w1.Range("B" & Rows.Count).End(xlUp).Row
            If Cells(R, 1).Top = chkbx.Top Then
                
                    lRow = w2.Range("B" & Rows.Count).End(xlUp).Row + 1
                    w2.Range("A" & lRow & ":I" & lRow).RowHeight = _
                    w1.Range("A" & R & ":I" & R).RowHeight
                    w1.Range("B" & R).Copy w2.Range("B" & lRow)
                    w1.Range("H" & R).Copy w2.Range("H" & lRow)
                    w1.Range("I" & R).Copy w2.Range("I" & lRow)
                    lRow = lRow + 1
                Exit For
            End If
        Next R
    End If
Next

End Sub

Sub ClearRowRange(): Dim R As Range, Pic As Object
Set R = Rows(ActiveCell.Row)
R.ClearContents
For Each Pic In ActiveSheet.Shapes
If Abs(Pic.Top - R.Top) < R.Height/2 Then
Pic.Delete
End If: Next
End Sub

* You also need to make the change highlighted in red

Hi Piranhao,

You're welcome!

(I didn't realize that you couldn't rep me again, I get reps from the same OP fairly often)