VBA用于搜索列中的字符串并根据相邻单元格中是否存在特定字符串复制整行
我是VBA的新手。 我有包含数字和字符串的excel数据表。我想在列中搜索某个字符串,比如'CYP',然后在列C中查找其行中的一个单元格,并复制包含单元格C字符串的整行。我想粘贴在同一工作簿的第2页中,并再次循环以查找列中的剩余CYP 你能帮我一下吗 根据pnuts的建议,下面是我的宏代码VBA用于搜索列中的字符串并根据相邻单元格中是否存在特定字符串复制整行,vba,excel,Vba,Excel,我是VBA的新手。 我有包含数字和字符串的excel数据表。我想在列中搜索某个字符串,比如'CYP',然后在列C中查找其行中的一个单元格,并复制包含单元格C字符串的整行。我想粘贴在同一工作簿的第2页中,并再次循环以查找列中的剩余CYP 你能帮我一下吗 根据pnuts的建议,下面是我的宏代码 Sub Macro1() ' ' Macro1 Macro ' ' Columns("I:I").Select Range("I729").Activate Selection.Fi
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
在这段代码中,CYP出现在I749中,单元格C749被复制为字符串,并搜索C列中包含相同字符串的第一行,然后复制整行,再复制4行,然后粘贴到同一工作簿的sheet2中。
我想要的是一次又一次地循环这个动作直到第一列的末尾,并重复同样的动作
谢谢大家! 在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
干杯 会让你开始的谢谢Siddharth Rout。我试过了,但找不到解决办法。有人帮忙吗?