excel-vba - 复制带有选中复选框的行

我想将带有选中复选框的行从三个表（“肝脏”，“肺”和“肾脏”）合并到一个表“报告”中。我想获取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（）-对Set1使用1，对Set2使用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 ...


就像这张图片



（复选框颜色只要遵循上述命名约定，就会通过代码重置）

。


通过运行Sub updateSet()生成两个文件，一个用于Set1，另一个用于Set2。


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

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


打开File1并运行Sub consolidateAllSheets()以生成Report_1
打开File2并运行Sub consolidateAllSheets()以生成Report_2

比较Report_1与Report_2

通过运行Sub updateSet()生成要编辑的Set 2


showSet 3显示Set1和Set2（所有复选框以及两个报告）-保存File3

比较File1，File2和File3