复制带有选中复选框的行 [英] copying rows with checked checkboxes
问题描述
我想将带有选中复选框的行从三张表(肝脏"，肺"和肾脏")合并到一张表报告"中.我想获取A列中不包含单词"sample"的行.当我将数据粘贴到"Report"中时，我想通过在包含该行的表之间添加一行来用相应的原始工作表名称标记每组行工作表名称，在A列中.
I would like to consolidate rows with checked checkboxes from three sheets ("Liver", "Lung" and "Kidney") into one sheet "Report". I would like to grab rows that do not contain word "sample" in column A. When I paste the data into "Report" I would like to label each group of rows with the corresponding originating sheet name by adding a row in between that contains the sheet name, in column A.
我想出了进入无限循环的这段代码，我必须杀死Excel才能停止它.这仅适用于肺"纸，但我希望将其复制用于其他两张纸. 理想情况下，我想使用数组来传输数据，但不确定如何计算.任何有关如何解决我已经拥有的或改进它的建议，将不胜感激.
I came up with this code which goes into an infinite loop and I have to kill Excel to stop it. This is just for "Lung" sheet only but I'm hoping to reproduce it for the other two sheets. Ideally, I would like to use arrays to transfer the data but I'm not sure how to work it out. Any suggestions on how to fix what I already have or to improve it would be greatly appreciated.
谢谢
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
推荐答案
以下代码将生成以下报告(详细信息如下):
The code bellow will generate the following reports (details bellow):
.
共有3个部分，但是所有代码都应粘贴到一个用户模块中:
There are 3 sections, but all code should be pasted into one user module:
.
要执行的订阅:
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列):
The process starts with one file, expected to have 2 sets of checkboxes on each sheet (column 2):
- cbSet1_01，cbSet1_02，cbSet1_03 ...
- cbSet2_01，cbSet2_02，cbSet2_03 ...
如图所示
(复选框颜色只要遵循上述命名约定，就会通过代码进行重置)
(check-box colors will be reset by code as long as they follow the naming convention above)
.
-
通过运行
Sub updateSet()
Generate two files, one for Set1, the other for Set2 by running
Sub updateSet()
-
showSet 1隐藏Set2(Report_2和所有工作表上的所有复选框)-保存File1 -
showSet 2隐藏Set1(Report_1和所有工作表上的所有复选框)-保存File2
分发，然后检索更新的文件
Distribute, then retrieve the updated files
- 打开File1并运行
Sub consolidateAllSheets()以生成Report_1 -
打开File2并运行
Sub consolidateAllSheets()以生成Report_2
- Open File1 and run
Sub consolidateAllSheets()to generate Report_1 Open File2 and run
Sub consolidateAllSheets()to generate Report_2
比较Report_1与Report_2
Compare Report_1 to Report_2
通过运行 Sub updateSet()
Generate Set 2 for editing by running Sub updateSet()
-
showSet 3显示Set1和Set2(所有复选框以及两个报告)-保存File3
showSet 3shows Set1 and Set2 (all checkboxes, and both reports) - Save File3
比较File1，File2和File3
Compare File1, File2, and File3
这篇关于复制带有选中复选框的行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
