3

我正在尝试为编写一个宏来搜索Sheet1和

  • 查找单词Force和Grade的所有实例，然后
  • 复制这些单词下方的单元格（所有单元格到第一个空行），然后粘贴到Sheet2.

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

到目前为止，我只能让它找到每个单词的第一个实例。我从本网站和其他网站的示例中尝试了多种类型的循环。

我觉得这应该很简单，所以我不确定为什么我找不到解决方案。我尝试了一个以For i To ws.Columns.Count（“ws”设置为 Sheet1）开头的 For Next 循环，但它变成了一个无限循环（尽管总列数只有 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
4

2 回答 2

2

您应该使用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
于 2013-07-16T03:13:08.230 回答
0

With Worksheets(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
于 2013-07-22T19:43:22.627 回答