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」の最初の空のセルが表示されるまで行をループし、すべてのコピーと貼り付けを実行してから停止するループです。それを達成するために何ができますか？

私の質問が漠然としていたり​​、理解しにくい場合はお知らせください。

mehow が提案したように、質問を更新して、私の試みのプレゼンテーションを行います:
変更はコメントでマークされます 

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

私はこれがあなたが探しているものだと思います.コードは明確にするためにコメントされています:

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、次のコードは、空白セル、値「R」、「P」、または行 1000 に到達するまで、列 A から B に値をコピーすることをループします。目的に合わせて変更できるはずです。

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 に答える