VBA代码查找值，在它旁边复制，直接粘贴或留下空白单元格

Question

我是新来的VBA编码，我希望有人能帮助我。

我试图编码一个循环来查找列a上的特定整数值(称为"TrialNumber")，检查列G的同一行上的值并将值粘贴到另一个工作簿。诀窍是，如果值小于100，我想要留下那个数量的空白单元格，而不是粘贴。数据如下所示:

Column A ... Column G
101          310
101          385
102          300
102          355
102          290
102          3
102          325
103          365
103          360
...          ...

让我们以102为例，我希望另一个工作簿中的输出看起来像这样:

Column A
300
355
290
blank cell
blank cell
blank cell
325

提前感谢!

Answer 1

将此宏粘贴到原始数据表中。它假设活动的工作表是数据表(带有试用编号的工作表)。

Public Sub ProcessTrialNumbers()
Dim rSource As Range ' Col A
Dim rTrialNo As Range ' current cell with trial number in Col A
Dim iMatchedValue As Integer ' matching value in Col G
Dim rTarget As Range ' Col in shtTarget where values will pasted
Dim iTargetRowIndex As Integer ' pointer to which row in target col I want the next value to be pasted
Const SWITCH_VALUE As Integer = 100 ' anything below this will switch on the blank rows logic

'define the Column A range to loop through
'there are different ways to do this - below is just one example
Set rSource = Cells(1, 1).CurrentRegion
' BEWARE: current region includes all contiguous cells
' you can also use:
Set rSource = ActiveSheet.Range("A1:A9")

'define the column to which values will be pasted
Set rTarget = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")

iTargetRowIndex = 1

For Each rTrialNo In rSource

' we can reference Column G by offset - it's just one way to get matching Col G value
' this way is not pretty and will break if anyone changes the spreadsheet
' but it serves as a quick example
iMatchedValue = rTrialNo.Offset(0, 6).Value

' either paste the value or move up iTargetRowIndex to skip rows
If iMatchedValue >= SWITCH_VALUE Then
rTarget(iTargetRowIndex, 1).Value = iMatchedValue
iTargetRowIndex = iTargetRowIndex + 1
Else
iTargetRowIndex = iTargetRowIndex + iMatchedValue
End If
Next rTrialNo
End Sub