复制带有选中复选框的行

我想将三张纸（“肝脏”、“肺”和“肾脏”）中选中复选框的行合并到一张“报告”中。我想抓取 A 列中不包含单词“sample”的行。当我将数据粘贴到“Report”中时，我想通过在其间添加一行，用相应的原始工作表名称来标记每组行，其中包含A 列中的工作表名称。

我想出了这段代码，它进入无限循环，我必须杀死 Excel 才能停止它。这仅适用于“肺”表，但我希望为其他两张表复制它。 理想情况下，我想使用数组来传输数据，但我不确定如何解决。任何关于如何修复我已有的或改进它的建议将不胜感激。

谢谢

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

下面的代码将生成以下报告（详细信息如下）：

.

有 3 个部分，但所有代码都应粘贴到一个用户模块中：

.

要执行的子程序：

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（） - 使用1 组 1, 2 组 2, Set2 已编辑 3 个:

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

.

合并报告()

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

.

该过程从一个文件开始，预计每张纸上有 2 组复选框（第 2 列）：

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

如这张图片所示

（复选框颜色将通过代码重置，只要它们遵循上面的命名约定）

.

1. 通过运行生成两个文件，一个用于 Set1，另一个用于 Set2Sub updateSet()

   • showSet 1隐藏 Set2（Report_2 和所有复选框，在所有工作表上）- 保存 File1
   • showSet 2隐藏 Set1（Report_1 和所有复选框，在所有工作表上）- 保存 File2

2. 分发，然后检索更新的文件

   • 打开File1并运行Sub consolidateAllSheets()生成 Report_1

   • 打开文件2并运行Sub consolidateAllSheets()生成 Report_2

     比较 Report_1 与 Report_2

3. 通过运行生成用于编辑的 Set 2Sub updateSet()

   • showSet 3显示 Set1 和 Set2（所有复选框和两个报告）- 保存文件 3

     比较文件 1、文件 2 和文件 3