VBA循环遍历工作表找字

我想写一个宏观的多个实例excel，搜索Sheet1和VBA循环遍历工作表找字

发现的话部队和所有实例级，然后
复制这些单词下面的单元格（所有单元格到第一个空行），并粘贴到Sheet2。

这些字（力和级）可以在Worksheet1任何细胞中发现和使用区域的大小改变每次创建该文件的时间。

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

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

这里是到目前为止的工作代码：您应该使用FindNext到indentify所有的比赛

我的代码

'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

来源

2013-07-16 teppuus

我会得到的行数，然后使用For每个循环根据方向 – Grant

。像这样的东西给所有单元格复制力的所有实例下面到Sheet2

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-16 03:13:08 brettdj

或每个循环添加或减去1注意，这确实假定在* force *下面存在一致的数据块，因此xldown块 – brettdj

上没有错误检查谢谢！我明天有空试试这些建议，并会让你知道。 – teppuus

你好，好的，所以我解决了这个问题，大部分时间都可以获得积极的结果。但是，在一些工作表上，我运行这个宏，循环变得无限。我不确定它为什么适用于某些工作表而不是其他工作表。任何线索？下面是90％的时间我会说的工作的代码。 – teppuus

的A列随着工作表（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-22 19:43:22 teppuus

VBA循环遍历工作表找字

回答

相关问题