首页 文章

VBA用于在列中搜索字符串并根据相邻单元格中某些字符串的存在复制整行

提问于
浏览
1

我对VBA来说是全新的 . 我有excel包含数字和字符串的数据表 . 我想在第一列中搜索某些字符串'CYP',然后在C列中查找其行的单元格并复制包含单元格C字符串的整行 . 我想粘贴到同一工作簿的工作表中并循环它再次寻找列中剩余的CYP .

你能帮帮我吗?

在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

在此代码中,CYP在I749中找到,单元格C749被复制为字符串,并且在包含相同字符串的列C中的第一行被搜索,然后复制整行,然后再复制4行,然后粘贴到同一工作簿的sheet2中 . 我想要的是一次又一次地循环这个动作直到第一列的结尾并重复相同的动作 .

谢谢!

1 回答

  • 0

    我设法在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
    

    干杯!

相关问题