与选中的复选框复制行

Question

我想从三个薄片（“肝脏”，“肺”和“肾”）组合成一个片“报告”与选中的复选框来巩固行。我想抢不包含单词“样本”列答：当我粘贴数据到“报告”行，我想在之间含有添加行标记每个组与对应的始发表名称行工作表名称，列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

代码波纹管会生成以下报告（详见波纹管）：

。

有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编辑：

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个上的每个片组复选框（第2栏）：

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

作为此图像

在0

（复选框颜色将通过代码，只要它们遵循上述命名约定被复位）。

1. 生成两个文件，一个用于设置1，其他为SET2运行Sub updateSet()

   • showSet 1隐藏SET2（Report_2和所有复选框，所有表） - 保存文件1
   • showSet 2隐藏Set1（Report_1和所有表格上的所有复选框） - 保存文件2

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

   • 打开文件1和运行Sub consolidateAllSheets()产生REPORT_1

   • 打开文件2和运行Sub consolidateAllSheets()产生Report_2

     比较REPORT_1到Report_2

3. 运行Sub updateSet()

   • showSet 3生成组2编辑显示SET1和SET2（所有复选框，并且这两份报告） - 保存文件3

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