VBA 用于在列中搜索字符串并根据相邻单元格中某个字符串的存在复制整行
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19461182/
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
VBA for searching string in a column and copy entire rows depending on the presence of certain string at adjacent cell
提问by Prakshbabu
I am completely new for VBA. I have excel data sheet containing numbers and strings. I want to search for certain string say 'CYP' in column I then look for a cell of its row at column C and copy entire rows containing the string of cell C. I want to paste in sheet 2 of the same workbook and loop it again to look for remaining CYPs in column.
我是 VBA 的新手。我有包含数字和字符串的 excel 数据表。我想在列中搜索某个字符串，比如“CYP”，然后在列 C 中查找其行的单元格并复制包含单元格 C 字符串的整行。我想粘贴到同一工作簿的第 2 页并循环它再次查找列中剩余的 CYP。
Would you help me on this please?
你能帮我解决这个问题吗？
After the suggestion from pnuts, here is my macro code
根据 pnuts 的建议，这是我的宏代码
Sub Macro1()
'
' Macro1 Macro
'
'
Columns("I:I").Select
Range("I729").Activate
Selection.Find(What:="cyp", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveWindow.SmallScroll Down:=5
Range("C749").Select
Selection.Copy
Columns("C:C").Select
Range("C734").Activate
Selection.Find(What:="EPT001TT0601C000151", After:=ActiveCell, LookIn:= _
xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext _
, MatchCase:=False, SearchFormat:=False).Activate
Rows("746:750").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
End Sub
In this code the CYP was found in I749, cell C749 was copied as string and first row in column C containing the same string was searched followed by copying of the entire row and 4 more followed by it then pasting in sheet2 of the same workbook. What I wanted was to loop this action again and again upto the end of column I and repeat the same action.
在此代码中，CYP 是在 I749 中找到的，单元格 C749 被复制为字符串，并搜索包含相同字符串的 C 列中的第一行，然后复制整行，然后再复制 4 行，然后粘贴到同一工作簿的 sheet2 中。我想要的是一次又一次地循环这个动作直到第一列的末尾并重复相同的动作。
Thank you!
谢谢！
采纳答案by Prakshbabu
I managed to solve the problem with the help of Trebor76 at Excelforum. Here I am giving solution in that way it might be helpful for some newbies like myself with similar problem.
我在 Excelforum 的 Trebor76 的帮助下设法解决了这个问题。在这里，我以这种方式提供解决方案，它可能对像我这样有类似问题的新手有所帮助。
Option Explicit
Sub Macro1()
'Written and assisted by Trebor76
'Copy an entire row from Sheet1 to Sheet2 for each unique matching item in Col. C if the text in Col. I contains the text 'CYP' (case sensitive)
'http://www.excelforum.com/excel-programming-vba-macros/962511-vba-for-searching-string-in-a-column-and-copy-rows-depending-on-string-in-adjacent-cell.html
Dim rngCell As Range
Dim objMyUniqueArray As Object
Dim lngMyArrayCounter As Long
Dim lngMyRow As Long
Dim varMyItem As Variant
Application.ScreenUpdating = False
Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
For Each rngCell In Sheets("Sheet1").Range("I1:I" & Sheets("Sheet1").Range("I" & Rows.Count).End(xlUp).Row)
If InStr(rngCell, "CYP") > 0 Then
If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "C"))) Then
lngMyArrayCounter = lngMyArrayCounter + 1
objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "C"))), lngMyArrayCounter
varMyItem = Sheets("Sheet1").Cells(rngCell.Row, "C")
For lngMyRow = 1 To Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
If Sheets("Sheet1").Cells(lngMyRow, "C") = varMyItem Then
Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next lngMyRow
End If
End If
Next rngCell
Set objMyUniqueArray = Nothing
Application.ScreenUpdating = True
MsgBox "All applicable rows have been copied.", vbInformation
End Sub
Cheers!
干杯!
