copying rows with checked checkboxes

Question

I would like to consolidate rows with checked checkboxes from three sheets (“Liver”, ”Lung” and “Kidney”) into one sheet "Report". I would like to grab rows that do not contain word "sample" in column A. When I paste the data into "Report" I would like to label each group of rows with the corresponding originating sheet name by adding a row in between that contains the sheet name, in column A.

I came up with this code which goes into an infinite loop and I have to kill Excel to stop it. This is just for "Lung" sheet only but I'm hoping to reproduce it for the other two sheets. Ideally, I would like to use arrays to transfer the data but I'm not sure how to work it out. Any suggestions on how to fix what I already have or to improve it would be greatly appreciated.

Thank you

For Each chkbx In ActiveSheet.CheckBoxes

 If chkbx.Value = 1 Then
    For r = 2 To Rows.count
         If Cells(r, 1).Top = chkbx.Top And InStr(Cells(r, 1).Value, "Sample") < 0 Then
         '
           With Worksheets("Report")
              LRow = .Range("A" & Rows.count).End(xlUp).Row + 1
            .Range("A" & LRow & ":P" & LRow) = _
             Worksheets("Lung").Range("A" & r & ":P" & r).Value
         End With
           Exit For
       End If
     Next r
   End If
 Next

Answer 1

The code bellow will generate the following reports (details bellow):

.

There are 3 sections, but all code should be pasted into one user module:

.

Subs to execute:

Option Explicit

Private Const REPORT    As String = "Report_"
Private Const EXCLUDE   As String = "Sample"
Private Const L_COL     As String = "P"

Private wsRep As Worksheet
Private lRowR As Long

Public Sub updateSet1()
    updateSet 1
End Sub
Public Sub updateSet2()
    updateSet 2
End Sub
Public Sub updateSet3()
    updateSet 3
End Sub

Public Sub updateSet(ByVal id As Byte)
    Application.ScreenUpdating = False
    showSet id
    Application.ScreenUpdating = True
End Sub

Public Sub consolidateAllSheets()
    Application.ScreenUpdating = False
    With ThisWorkbook
        consolidateReport .Worksheets("COLON"), True  'time stamp to 1st line of report
        consolidateReport .Worksheets("LUNG")
        consolidateReport .Worksheets("MELANOMA")
        wsRep.Rows(lRowR).Borders(xlEdgeBottom).LineStyle = xlContinuous
    End With
    Application.ScreenUpdating = True
End Sub

.

showSet() - use 1 for Set1, 2 for Set2, 3 for Set2 edited:

Public Sub showSet(ByVal id As Byte)
    Dim ws As Worksheet, cb As Shape, lft As Double, mid As Double, thisWs As Worksheet
    Dim lRed As Long, lBlu As Long, cn As String, cbo As Object, s1 As Boolean

    If id <> 1 And id <> 2 And id <> 3 Then Exit Sub

    lRed = RGB(255, 155, 155): lBlu = RGB(155, 155, 255)
    Set thisWs = ThisWorkbook.ActiveSheet
    For Each ws In ThisWorkbook.Worksheets
        If InStr(1, ws.Name, REPORT, vbTextCompare) = 0 Then
            lft = ws.Cells(1, 2).Left
            mid = lft + ((ws.Cells(1, 2).Width / 2) - 5)
            For Each cb In ws.Shapes
                cn = cb.Name
                Set cbo = cb.OLEFormat.Object
                s1 = InStr(1, cn, "set1", 1) > 0
                If id < 3 Then
                    cb.Visible = IIf(s1, (id = 1), (id <> 1))
                    cb.Left = IIf(cb.Visible, mid, lft)
                    cbo.Interior.Color = IIf(s1, lBlu, lRed)
                Else
                    cb.Visible = True
                    cb.Left = IIf(s1, lft + 3, mid + 6.5)
                    cbo.Interior.Color = IIf(s1, lBlu, lRed)
                End If: ws.Activate
                With cbo
                    .Width = 15
                    .Height = 15
                End With
            Next
        Else
            ws.Visible = IIf((id = 3), -1, IIf(InStr(1, ws.Name, id) = 0, 0, -1))
        End If
    Next
    thisWs.Activate   'to properly update checkbox visibility
End Sub

.

consolidateReport()

Public Sub consolidateReport(ByRef ws As Worksheet, Optional dt As Boolean = False)
    Dim fRowR As Long, vSetID As Byte, vSetName As String
    Dim lRow As Long, thisRow As Long, cb As Variant

    vSetID = IIf(ws.Shapes("cbSet2_03").Visible, 2, 1)
    vSetName = "Set" & vSetID
    Set wsRep = ThisWorkbook.Worksheets(REPORT & vSetID)
    fRowR = wsRep.Range("A" & wsRep.Rows.count).End(xlUp).Row
    If Not ws Is Nothing Then
        With ws
            lRow = .Range("A" & .Rows.count).End(xlUp).Row
            lRowR = fRowR + 1
            With wsRep.Cells(lRowR, 1)
                .Value2 = ws.name
                .Interior.Color = vbYellow
                If dt Then .Offset(0, 2) = Format(Now, "mmm dd yyyy, hh:mm AMPM")
            End With
            For Each cb In .Shapes
                If InStr(1, cb.name, vSetName, 0) Then
                    If cb.OLEFormat.Object.Value = 1 Then
                        thisRow = cb.TopLeftCell.Row
                        If InStr(1, .Cells(thisRow, 1).Value2, EXCLUDE, 1) = 0 Then
                            lRowR = lRowR + 1
                            wsRep.Range("A" & lRowR & ":" & L_COL & lRowR).Value2 = _
                                .Range("A" & thisRow & ":" & L_COL & thisRow).Value2
                        End If
                    End If
                End If
            Next
            If fRowR = lRowR - 1 Then
                wsRep.Cells(lRowR, 1).EntireRow.Delete
                lRowR = lRowR - 1
                MsgBox "No checkboxes checked for sheet " & ws.name
            End If
        End With
    End If
End Sub

.

The process starts with one file, expected to have 2 sets of checkboxes on each sheet (column 2):

• cbSet1_01, cbSet1_02, cbSet1_03...
• cbSet2_01, cbSet2_02, cbSet2_03...

as in this image

(check-box colors will be reset by code as long as they follow the naming convention above)

.

1. Generate two files, one for Set1, the other for Set2 by running Sub updateSet()

   • showSet 1 hides Set2 (Report_2 and all checkboxes, on all sheets) - Save File1
   • showSet 2 hides Set1 (Report_1 and all checkboxes, on all sheets) - Save File2

2. Distribute, then retrieve the updated files

   • Open File1 and run Sub consolidateAllSheets() to generate Report_1

   • Open File2 and run Sub consolidateAllSheets() to generate Report_2

     Compare Report_1 to Report_2

3. Generate Set 2 for editing by running Sub updateSet()

   • showSet 3 shows Set1 and Set2 (all checkboxes, and both reports) - Save File3

     Compare File1, File2, and File3