copying rows with checked checkboxes - excel

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)
.
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
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
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