3

検索を行うのマクロを書こうとしています。Sheet1

  • ForceおよびGradeという単語のすべてのインスタンスを検索し、次に
  • これらの単語の下のセルをコピーし (すべてのセルを最初の空の行に)、 に貼り付けSheet2ます。

これらの単語 ( ForceとGrade ) は Worksheet1 の任意のセルにあり、使用される領域のサイズはファイルが作成されるたびに変化します。

これまでのところ、各単語の最初のインスタンスを見つけることしかできません。このウェブサイトや他のサイトの例から、さまざまな種類のループを試しました。

これは簡単なはずだと思うので、なぜ解決策が見つからないのかわかりません。("ws" を Sheet1 に設定して)で始まる For Next ループを試してみましたFor i To ws.Columns.Countが、無限ループに変わります (ただし、合計列数は約 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 に答える