[英]Copy/Paste column range based on cell value
我有一个内容丰富的工作簿,其中包含大约 500 个自定义命名的工作表,这些工作表是由一个宏创建的,该宏处理了来自核心数据集的数据。 所有工作表都遵循相同的格式。
在这约 500 个工作表中的每一个工作表的 QG27:SO27 范围内,如果上述所有单元格都满足特定条件,则有一个公式显示“TRUE”,否则它们为空白
我的挑战是将“TRUE”数据整理到名为“COLLATED TRUE VALUES”的单独工作表中。 通过扫描每个工作表上的 QG27:SO27,如果 QG27:SO27 中的单元格包含“TRUE”,则将该列从第 1:27 行复制并粘贴到名为“COLLATED TRUE VALUES”的工作表的 C2 并复制/粘贴工作表名称从C1中提取。 遇到的每个额外的“TRUE”都会将相同的相应数据复制/粘贴到“COLLATED TRUE VALUES”表中的下一列,并继续浏览所有工作表
我已经考虑了一个循环,遍历可能包含“TRUE”的范围,并逐步遍历 500 张工作表中的每一张,但他的过程将是一个缓慢的过程,我希望需要在许多其他工作簿中重用这种类型的场景。
我需要一些帮助来创建一个可以以最有效的方式整理所需日期的宏
Option Explicit
Sub CollateTrueValues()
' Define constants.
' Source
Const srgAddress As String = "QG1:SO27"
Const sBoolean As Boolean = True
' Destination
Const dName As String = "COLLATED TRUE VALUES"
Const dFirstCellAddress As String = "C1"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the destination worksheet ('dws').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' Reference the destination first cell ('dfCell').
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
' Write the number of rows and columns to variables ('rCount', 'cCount').
Dim rCount As Long
Dim cCount As Long
With dws.Range(srgAddress)
rCount = .Rows.Count
cCount = .Columns.Count
End With
' Declare additional variables.
Dim sws As Worksheet
Dim srg As Range
Dim sValue As Variant
Dim Data As Variant
Dim sName As String
Dim r As Long
Dim sc As Long
Dim dc As Long
' Loop...
For Each sws In wb.Worksheets
' Check if it's not the destination worksheet.
If Not sws Is dws Then
' Write the source worksheet name to a variable ('sName').
sName = sws.Name
' Write the source data to a 2D one-based array ('Data').
Data = sws.Range(srgAddress).Value
' Write the matching data to the left 'dc' columns of the array.
For sc = 1 To cCount
sValue = Data(rCount, sc)
If VarType(sValue) = vbBoolean Then
If sValue = sBoolean Then
dc = dc + 1
For r = 1 To rCount
Data(r, dc) = Data(r, sc)
Next r
'Else ' is not a match (True), do nothing
End If
'Else ' is not a boolean; do nothing
End If
Next sc
' Write the matching data to the destination worksheet.
If dc > 0 Then
With dfCell.Resize(, dc)
.Value = sName ' write worksheet name
.Offset(1).Resize(rCount).Value = Data ' write data
End With
Set dfCell = dfCell.Offset(, dc) ' next first destination cell
dc = 0
'Else ' no matching (True) values; do nothing
End If
'Else ' it's the destination worksheet; do nothing
End If
Next sws
' Clear to the right.
dfCell.Resize(rCount + 1, dws.Columns.Count - dfCell.Column + 1).Clear
' Inform.
MsgBox "True values collated.", vbInformation
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.