Excel Checkbox - How do i duplicate entire row when checkbox is ticked?

[ozc1han]

Hi all,

I've always found my answers to excel questions on mrexcel, however, at the moment I'm struggling! I'm not that experienced with Excel.

I have made a checklist with Check Boxes (Form Control), which is linked to the column beside it. When checked, TRUE appears in the column beside the checkbox and the checkbox highlights the row so it is clearly selected.

When checked I need the row to be duplicated (into another sheet [sheet 2]). When unchecked from sheet 2, I need to row be removed. Sheet 2 is basically going to be where I'd like all checked items from different sheets to appear.
If the row can't be duplicated, I would like it to be moved (into another sheet [sheet 2]).

Any help will be highly appreciated!

Thank you

 

[Logit]

You are welcome.

 

[ozc1han]

Hi, how can I edit my checklist to delete the row, once it has moved from the source sheet, to destination sheet?

The code can be found here:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, Range("G4:G2000")) Is Nothing Then
Application.EnableEvents = False

If ActiveCell.Value = ChrW(&H2713) Then
ActiveCell.clearcontents
ActiveCell.EntireRow.Interior.Color = xlNone
Else
ActiveCell.Value = ChrW(&H2713)
ActiveCell.EntireRow.Interior.ColorIndex = 2
End If
Application.ScreenUpdating = True

Cancel = True

End If

Application.EnableEvents = True

Copy_n_Paste

End Sub


Sub Copy_n_Paste()
On Error Resume Next

Dim srchtrm As String
Dim rng As Range, destRow As Long
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim c As Range
Dim i As Integer
Dim Today As Date

With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Sheet11.Rows("16:2000").Delete

Set shtSrc = Sheets("Checklist") 'source sheet
Set shtDest = Sheets("Inspection Report") 'destination sheet
destRow = 16 'start copying to this row

'don't scan the entire column...
Set rng = Application.Intersect(shtSrc.Range("G:G"), shtSrc.UsedRange)

For Each c In rng.Cells
If c.Value = ChrW(&H2713) Then

c.EntireRow.Copy shtDest.Cells(destRow, 1)

destRow = destRow + 1

End If
Next

Sheet11.Columns("A:H").EntireColumn.AutoFit

Worksheets("Inspection Report").Range("A:A").ColumnWidth = 15
Worksheets("Inspection Report").Range("B:B").ColumnWidth = 28
Worksheets("Inspection Report").Range("C:C").ColumnWidth = 28
Worksheets("Inspection Report").Range("D:D").ColumnWidth = 28
Worksheets("Inspection Report").Range("E:E").ColumnWidth = 10
Worksheets("Inspection Report").Range("F:F").ColumnWidth = 0
Worksheets("Inspection Report").Range("G:G").ColumnWidth = 4
Worksheets("Inspection Report").Range("H:H").ColumnWidth = 0
Sheet11.Rows("16:2000").Rows.AutoFit


With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With

Application.CutCopyMode = False
Sheets("Operations - Data").Range("A1").Select

End Sub