vba 循环直到找到某个值
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/18312427/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
looping until certain value is found
提问by Artur Rutkowski
I have a following problem (and an urging desire to overcome it:)). I need to make my loop to go through rows until certain value is found. Let me demonstrate what I need in more detail on my code:
我有以下问题（并且迫切希望克服它:)）。我需要让我的循环遍历行，直到找到某个值。让我在我的代码中更详细地演示我需要什么：
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
This code simply goes through rows, and when a specified cell, in this case cell in column "C", is empty it does all the copying and pasting. BUT! It does it as much time as I have denoted it (For i = 1 To 121). What I need is a loop that would loop trough rows until first empty cell in column "D" appears, then perform all the copying and pasting and then STOP. What can I do in order to achieve that?
此代码只是遍历行，当指定的单元格（在本例中为“C”列中的单元格）为空时，它将执行所有复制和粘贴操作。但！它做的时间和我所表示的一样多（对于 i = 1 到 121）。我需要的是一个循环，它会循环遍历行，直到出现“D”列中的第一个空单元格，然后执行所有复制和粘贴，然后停止。我能做些什么来实现这一目标？
Please let me know if my question is vague or hard to understand in any way.
如果我的问题含糊不清或难以理解，请告诉我。
As mehow suggested I update my question with a presentation of my try:
Changes are marked 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
回答by ApplePie
Add Exit Forat the end of the inner Ifso that when you execute your copying you can get out of it and get to the next row.
添加Exit For在内部的末尾，If以便在执行复制时可以摆脱它并进入下一行。
回答by tigeravatar
I think this is what you're looking for, code commented for clarity:
我认为这就是你要找的，为了清楚起见，代码注释了：
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
回答by Graham Anderson
Artur, the following code will loop copying values from column A to B until it comes across a blank cell, the values "R", "P", or it reaches row 1000. You should be able to modify it for your purposes.
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
