尝试将一行中的特定列复制到符合特定条件的另一个excel工作表中。

Question

我对excel/vba非常陌生，并试图使用宏检查列的值是否为true，当它看到该值时，我希望它将该行的部分复制到列中的另一个工作表中。然后，我需要它迭代其他行并执行相同的检查。这是我目前的代码。

Sub Macro3()
'
' Macro3 Macro
'

'
Sheets("Aspen Data").Select
Dim tfCol As Range, Cell As Object


Set tfCol = Range("G26:G56")

Sheets("Code").Select
ActiveSheet.Calculate
Sheets("Aspen Data").Select
ActiveSheet.Calculate

For Each Cell In tfCol

    If IsEmpty(Cell) Then
        Exit Sub
    End If

    If Cell.Value = "True" Then

Range("I26:Q26").Select
Selection.Copy
Sheets("AspenHist").Select
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    End If

    Next


End Sub

问题似乎是让我的范围(“I26:Q26”)在循环过程中增加一个。

Answer 1

尝尝这个

Sheets("Aspen Data").Select
Dim i As Integer

Sheets("Code").Calculate
Sheets("Aspen Data").Calculate

For i = 26 To 56

If IsEmpty(Cells(i, 7)) Then
    Exit Sub
ElseIf Cells(i, 7).Value = "True" Then

Range(Cells(i, 9), Cells(i, 12)).Copy
Sheets("AspenHist").Activate
Range("B" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Aspen Data").Activate
End If

Next i

Answer 2

没有必要使用.Select/.Activate/ActiveSheet (参见this)来完成您的目标，您肯定可以使用For Each。试试这个：

Option Explicit

Sub Macro1()
    '
    ' Macro1 Macro
    '

    '
    Dim tfCol As Range, Cell As Object

    Set tfCol = Sheets("Aspen Data").Range("G26:G56")

    Application.ScreenUpdating = False

    Sheets("Code").Calculate
    Sheets("Aspen Data").Calculate

    For Each Cell In tfCol

        If IsEmpty(Cell) Then
            Exit For
        End If

        If Cell.Value = "True" Then

            Sheets("Aspen Data").Range("I" & Cell.Row & ":Q" & Cell.Row).Copy
            Sheets("AspenHist").Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial _
                Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If

    Next

    Application.ScreenUpdating = True

End Sub