1

我对 VBA 完全陌生。我有包含数字和字符串的 excel 数据表。我想在列中搜索某个字符串，例如“CYP”，然后在 C 列中查找其行的一个单元格并复制包含单元格 C 字符串的整行。我想粘贴到同一工作簿的第 2 表中并循环它再次查找列中剩余的 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

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

谢谢！

4

1 回答 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

干杯!

于 2013-10-20T13:22:35.987 回答