0

我有以下问题（以及克服它的迫切愿望:)）。我需要让我的循环遍历行，直到找到某个值。让我在我的代码中更详细地演示我需要什么： 

For x = 1 To 1000
    If Cells(x, "O").Value = "P" Or Cells(x, "O").Value = "R" Then

        Dim i As Integer
        For i = 1 To 121
            If Worksheets(Cells(x, "P").Value).Cells(Cells(x, "Q").Value + i, "C") = "" Then
                With Worksheets(Cells(x, "P").Value)
                    .Cells(Cells(x, "Q").Value + i, "A").Resize(, 20).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    Range("F" & x, "H" & x).Copy
                    .Cells(Cells(x, "Q").Value + i, "E").PasteSpecial xlPasteAll
                    .Cells(Cells(x, "Q").Value + i, "C") = "Pur"
                    Range("AI" & x).Copy
                    .Cells(Cells(x, "Q").Value + i, "O").PasteSpecial xlPasteAll
                End With
            End If
        Next i

    End If

此代码只是遍历行，当指定的单元格（在本例中为“C”列中的单元格）为空时，它会执行所有复制和粘贴。但！它执行的时间与我所指出的一样多（对于 i = 1 到 121）。我需要的是一个循环，它将循环遍历行，直到出现“D”列中的第一个空单元格，然后执行所有复制和粘贴，然后停止。我能做些什么来实现这一目标？

如果我的问题含糊不清或难以理解，请告诉我。

正如我所建议的那样，我通过演示我的尝试来更新我的问题： Changes aremarked
with comments 

Dim a As Integer 'I introduced new variable
a = 121          'This is it

For x = 1 To 1000
If Cells(x, "O").Value = "P" Or Cells(x, "O").Value = "R" Then

    Dim i As Integer
    For i = 1 To a 'Changes
        If Worksheets(Cells(x, "P").Value).Cells(Cells(x, "Q").Value + i, "C") = "" Then
            With Worksheets(Cells(x, "P").Value)
                .Cells(Cells(x, "Q").Value + i, "A").Resize(, 20).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Range("F" & x, "H" & x).Copy
                .Cells(Cells(x, "Q").Value + i, "E").PasteSpecial xlPasteAll
                .Cells(Cells(x, "Q").Value + i, "C") = "Pur"
                Range("AI" & x).Copy
                .Cells(Cells(x, "Q").Value + i, "O").PasteSpecial xlPasteAll
            End With
        a = i ' This way I wanted to end the loop sooner
        End If
    Next i

End If
4

3 回答 3

1

Exit For在内部的末尾添加，If以便在执行复制时可以退出并进入下一行。

于 2013-08-19T11:18:33.257 回答
1

我认为这就是您正在寻找的，为清楚起见，代码注释：

Sub tgr()

    'Declare variables
    Dim wsData As Worksheet     'Sheet where the data is stored
    Dim wsDest As Worksheet     'Sheet that appropriate data will be copied to
    Dim rngFound As Range       'Range variable used to loop through column O on wsData
    Dim varSheetName As Variant 'Variable used to loop through the sheet names that we will be looking for with rngFound
    Dim strFirst As String      'Used to record the first found cell in order to avoid an infinite loop
    Dim lRow As Long            'Used to determine the row that found data will be pasted to in wsDest

    'Assign wsData to the sheet containing the data
    Set wsData = Sheets("Sheet1")

    'Start the loop by going through each value you are looking for
    'Based on your post, you are looking for "P" and "R"
    For Each varSheetName In Array("P", "R")

        'The values we are looking for are also sheetnames
        'Assign wsDest to the value
        Set wsDest = Sheets(varSheetName)

        'In wsData, look for the value within column "O", must be an exact, case-sensitive match
        Set rngFound = wsData.Columns("O").Find(varSheetName, wsData.Cells(Rows.Count, "O"), xlValues, xlWhole, MatchCase:=True)
        If Not rngFound Is Nothing Then

            'Found a match, record the first match's cell address
            strFirst = rngFound.Address

            'Start a new loop to find every match
            Do

                'Determine the next empty row based on column C within wsDest
                lRow = wsDest.Cells(Rows.Count, "C").End(xlUp).Row + 1

                'Column C at the new row should be set to "Pur"
                wsDest.Cells(lRow, "C").Value = "Pur"

                'Copy columns F:H within wsData and paste to column E within wsDest at the new row
                wsData.Range("F" & rngFound.Row & ":H" & rngFound.Row).Copy wsDest.Cells(lRow, "E")

                'Copy column AI within wsData and paste to column O within wsDest at the new row
                wsData.Cells(rngFound.Row, "AI").Copy wsDest.Cells(lRow, "O")

                'Advance the loop to the next matching cell
                Set rngFound = wsData.Columns("O").Find(varSheetName, rngFound, xlValues, xlWhole, MatchCase:=True)

            'Exit the loop when we are back at the first matching cell
            Loop While rngFound.Address <> strFirst

        End If

    'Advance to the next value (which is a sheet name) that you will be looking for
    Next varSheetName

    'Object variable cleanup
    Set wsData = Nothing
    Set wsDest = Nothing
    Set rngFound = Nothing

End Sub
于 2013-08-19T18:31:29.537 回答
0

Artur，以下代码将循环从 A 列复制值到 B，直到遇到空白单元格、值“R”、“P”或到达第 1000 行。您应该能够根据您的目的对其进行修改。

Sub Stack2()
Dim lRowCounter As Long

lRowCounter = 1

Do While lRowCounter < 1000 _
         And Cells(lRowCounter, "A").Value <> "P" _
         And Cells(lRowCounter, "A").Value <> "R" _
         And Cells(lRowCounter, "A").Value <> ""

    Cells(lRowCounter, "B").Value = Cells(lRowCounter, "A").Value


lRowCounter = lRowCounter + 1
Loop

End Sub
于 2013-08-19T17:58:11.643 回答