與選中的複選框複製行

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