VBA用于在列中searchstring，并根据相邻单元格中是否存在特定string来复制整个行

我对VBA来说是全新的。 我有excel包含数字和string的数据表。 我想在列I中search特定的string“CYP”，然后在列C中查找其行的单元格，并复制包含单元格C的string的整行。我想粘贴到同一个工作簿的工作表2中并循环再次查找列中剩余的CYP。

你能帮我吗？

从pnuts的build议，这里是我的macros代码

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 

在此代码中，在I749中findCYP，将单元格C749作为string复制，并在列C中包含相同string的第一行进行search，然后复制整个行，然后再复制4行，然后粘贴到同一工作簿的工作表2中。 我想要的是一次又一次地循环这个动作到第一列的结尾，并重复同样的动作。

谢谢！

Answer 1

我在Excelforum的Trebor76帮助下解决了这个问题。 在这里我给出了解决scheme，对于像我这样的类似问题的新手可能会有所帮助。

 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 

干杯!