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循環遍歷工作表找字

回答

相關問題