VBA通过工作表循环查找单词的多个实例
我正在试图写一个Excel的macros来searchSheet1和
- 然后查找单词Force和Grade的所有实例
- 复制这些单词下的单元格（所有单元格到第一个空行），并粘贴到
Sheet2。
这些单词（ 强制和等级 ）可以在Worksheet1中的任何单元格中find，并且每次创build文件时所用区域的大小都会更改。
到目前为止，我只能find每个单词的第一个实例。 我已经尝试了许多types的循环从本网站和其他人的例子。
我觉得这应该是简单的，所以我不知道为什么我找不到解决scheme。 我已经尝试了一个For Next循环，开始For i To ws.Columns.Count （“ws”设置为Sheet1），但它变成一个无限循环（尽pipe总列数只有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
你应该使用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
用工作表（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