Question

我想将带有三张复选框的行（“肝脏”，“肺”和“肾脏”）合并到一张“报告”中。我想在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

Answer 1

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

result

共有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代表Set1 ， 2代表Set2 ， 3代表Set2编辑：< / p>

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

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

cbSet1_01，cbSet1_02，cbSet1_03 ......
cbSet2_01，cbSet2_02，cbSet2_03 ......

如此图片

enter image description here

（只要符合上面的命名约定，复选框颜色将由代码重置）

通过运行 Sub updateSet()
生成两个文件，一个用于Set1，另一个用于Set2
- showSet 1 隐藏Set2（所有工作表上的Report_2和所有复选框） - 保存文件1
- showSet 2 隐藏Set1（所有工作表上的Report_1和所有复选框） - 保存文件2
分发，然后检索更新的文件
- 打开File1并运行 Sub consolidateAllSheets() 以生成Report_1
- 打开File2并运行 Sub consolidateAllSheets() 以生成Report_2
  
  将Report_1与Report_2进行比较
通过运行 Sub updateSet()
生成第2组进行编辑
- showSet 3 显示Set1和Set2（所有复选框和两个报告） - 保存文件3
  
  比较File1，File2和File3

使用选中的复选框复制行

1 个答案: