Copy rows to new sheet depending on what column the check box is checked..... please help.

[Glove83]

Hi,

I have a problem and i have found part of the solution online but it doesn't quite do exactly what i need it to. I'm hoping some of you gurus can maybe help me as i am not very knowledgeable with regards to VB.

I have a worksheet with varying rows of data which at the end of the last column of data (H) there are three columns with check boxes (I = YES, J = NO, K = More Info) What i am trying to do is copy the checked rows to a new workbook depending on what is checked. So a check in (I = YES) would copy the data to the YES workbook.

I found some code online that will export anything that is checked to a new workbook but i don't know how to edit the code to fulfill my task. It also does a lot of other things such as the count and total which i don't need but i was wary of posting it without that code as it may be important to the overall functionality. The code is as follows.

Sub AddSheetandCopy() 'opens a new workbook
Dim sShape As Shape
Dim wsWB As Workbook
Dim wsStart As Worksheet
Dim Pastedws As String
Dim CountChecked As Integer   'Used To Count whether there is ticked check box
Dim SelectedWB As Variant


Set wsStart = ActiveSheet


SelectedWB = Application.GetOpenFilename("Excel (xls*), *.xls")


Application.ScreenUpdating = False


If SelectedWB <> False Then
    Application.DisplayAlerts = False
    Set wsWB = Workbooks.Open(SelectedWB)
    Application.DisplayAlerts = True
Else:
    Set wsWB = Workbooks.Add()            'If Select No Sheet
End If


For Each sShape In wsStart.Shapes
    With sShape
        If .FormControlType = xlCheckBox Then
            If .ControlFormat.Value = xlOn And wsStart.Range(.TopLeftCell.Address).Offset(, 1).Value <> 1 Then
                CountChecked = CountChecked + 1
                wsStart.Range(.TopLeftCell.Address).EntireRow.Copy _
                Destination:=wsWB.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2, 1)
                wsStart.Range(.TopLeftCell.Address).Offset(, 1) = 1          'Recorded Copied Record
            End If
        End If
    End With
Next sShape


If CountChecked > 0 Then
    ActiveSheet.Range("a1").Resize(, wsStart.UsedRange.Columns.Count) = wsStart.UsedRange.Rows(1).Value
    wsWB.Sheets(1).Range("F65536").End(xlUp).Offset(1).Formula = _
    "=Sum(" & Range(wsWB.Sheets(1).Range("F1"), wsWB.Sheets(1).Range("F65536").End(xlUp)).Address(rowabsolute:=False, columnabsolute:=False) & ")"
    wsWB.Sheets(1).Range("F65536").End(xlUp).Offset(, -4) = "Total:"
    wsWB.Sheets(1).DrawingObjects.Delete
    
    On Error Resume Next
    wsWB.Close savechanges:=True, Filename:=ThisWorkbook.Path & "\" & " " & Format(Now(), "dd-mm-yyyy") & ".xls"
    On Error GoTo 0
    
Else:
    Application.DisplayAlerts = False
    ActiveWorkbook.Close savechanges = False
    Application.DisplayAlerts = True
    
    msg = MsgBox("There isn't Any Record Checked", vbInformation)
    Exit Sub
End If


End Sub

I would really appreciate any help/guidance on this problem.