Question

我正在尝试为搜索Sheet1和

的excel编写一个宏

找到强制和成绩的所有单词实例，然后
将单元格下方的单元格（所有单元格复制到第一个空行），并粘贴到Sheet2。

这些单词（ Force 和 Grade ）可以在Worksheet1的任何单元格中找到，每次创建文件时，使用区域的大小都会更改。

到目前为止，我只能找到每个单词的第一个实例。我在本网站和其他网站上的例子中尝试了很多类型的循环。

我觉得这应该很简单，所以我不确定为什么我找不到解决方案。我尝试过以For i To ws.Columns.Count开头的For Next循环（“ws”设置为Sheet1），但它变成了一个无限循环（尽管总列数只有15左右）。任何帮助或推动正确的方向将不胜感激。

以下是迄今为止有效的代码：

我的代码

'COPY AND PASTE ALL FORCE VALUES TO FROM SHEET1 TO SHEET2
Sheets("Sheet1").Select
Cells.Find(What:=strSearch1, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Activate   'select cell below the word "Force"
Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Force" to first empty cell
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select 'paste to next column
ActiveSheet.Paste

Answer 1

您应该使用FindNext来识别所有匹配项。像这样将所有 Force 实例下的所有单元格复制到Sheet2的A列

Dim StrSearch As String
Dim rng1 As Range
Dim rng2 As Range

StrSearch = "Force"

With Worksheets(1).UsedRange
    Set rng1 = .Find(StrSearch, , xlValues, xlPart)
    If Not rng1 Is Nothing Then
        strAddress = rng1.Address
        Set rng2 = rng1
        Do
            Set rng1 = .FindNext(rng1)
            Set rng2 = Union(rng2, rng1)
        Loop While Not rng1 Is Nothing And rng1.Address <> strAddress
    End If
End With

If Not rng2 Is Nothing Then
For Each rng3 In rng2
Range(rng2.Offset(1, 0), rng3.End(xlDown)).Copy Sheets(2).Cells(Rows.Count, "A").End(xlUp)
Next
End If

Answer 2

使用工作表（1）.UsedRange

    'Code to copy and paste Force values
    Set rng1 = .Find(strSearch1, LookIn:=xlValues)
    SampleCnt = Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:BJ2000"), "Grade")

    Do While i < SampleCnt
        rng1.Offset(1, 0).Activate   'select cell below the word "Force"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Force" to first empty cell
        numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
        Selection.Copy
        Sheets("Sheet2").Select
        Worksheets("Sheet2").Columns(Cnt).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Set rng1 = .FindNext(rng1)
        Cnt = Cnt + 2
        i = i + 1
    Loop

    'Code to copy and paste Grade values

    Cnt = 4
    i = 0
    Set rng2 = .Find(strSearch2, LookIn:=xlValues)

    Do While i < SampleCnt
        rng2.Offset(1, 0).Activate   'select cell below the word "Grade"
        Range(ActiveCell, ActiveCell.End(xlDown)).Select    'select all cells after "Grade" to first empty cell
        numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
        Selection.Copy
        Sheets("Sheet2").Select
        Worksheets("Sheet2").Columns(Cnt).Select
        ActiveSheet.Paste
        Sheets("Sheet1").Select
        Set rng2 = .FindNext(rng2)
        Cnt = Cnt + 2
        i = i + 1
    Loop

End With

VBA循环通过工作表来查找单词的多个实例

2 个答案: