2

列AIに多くの用語が含まれているワークシートがあり、たとえば用語Aと用語Bの2つの用語を検索し、2つの用語の間のすべての行をコピーして、新しいシートに貼り付けます。これら2つの用語が列で繰り返される場合があります。私が基本的に直面している問題は、次の問題です。コードを実行するたびに、用語Bと用語Aの間の行もコピーされます。これは不要です。以下は、用語Aと用語Bの2つの用語に使用しているコードです。たとえば、私の列Aは

インスティテュートイベントジョブコンピューターラップトップフィギュアイベントフィギュアフォーマットコンピューター

さらに、用語A：イベントと用語B：ラップトップの間のすべての行をコピーして、新しいシートに貼り付けたいと思います。私のコードが行っているのは、イベントとコンピューターのすべての組み合わせの間で行をコピーすることです。コンピューターとイベントの間の行もコピーされます（この場合はFigureとラップトップ）。 

Sub OpenHTMLpage_SearchIt()
    Dim Cell As Range, Keyword$, N%, SearchAgain As VbMsgBoxResult
    Dim ass As Variant
    Dim Cellev As Range, prakash$, P%, SearchAgaina As VbMsgBoxResult
    Dim asa As Variant


StartSearch:
    N = 1
    Keyword = "Event"

    If Keyword = Empty Then GoTo StartSearch
    For Each Cell In Range("A1:A500")
        If Cell Like "*" & Keyword & "*" Then

        ass = Cell.Address

        P = 1
        prakash = "Computer"
        If prakash = Empty Then GoTo StartSearch
            For Each Cellev In Range("A1:A500")
                If Cellev Like "*" & prakash & "*" Then
                    asa = Cellev.Address

                    Range(asa, ass).Select
                    Selection.Copy
                    Sheets.Add After:=Sheets(Sheets.Count)
                    Range("B13").Select
                    ActiveSheet.Paste

                    Worksheets("sheet1").Select
                    P = P + 1
                End If
            Next Cellev
            N = N + 1
        End If
    Next Cell

End Sub

編集：コードのフォーマット。

4

2 に答える 2

2

以下は、私のために働いているコードです。これにより、イベントとラップトップの間のすべてがコピーされ、新しいシートに貼り付けられます。その後、2 回目の検索が行われ、今度は次の行から最初の検索まで検索が開始されます。

  Sub Star123()
   Dim rownum As Long
   Dim colnum As Long
   Dim startrow As Long
   Dim endrow As Long
   Dim lastrow As Long
   rownum = 1
   colnum = 1
   lastrow = Worksheets("Startsheet").Range("A65536").End(xlUp).Row
   With ActiveWorkbook.Worksheets("StartSheet").Range("a1:a" & lastrow)


   For rownum = 1 To lastrow
    Do
       If .Cells(rownum, 1).Value = "Event" Then
          startrow = rownum
       End If

       rownum = rownum + 1


   If (rownum > lastrow) Then Exit For

   Loop Until .Cells(rownum, 1).Value = "Laptop"
   endrow = rownum
   rownum = rownum + 1

   Worksheets("StartSheet").Range(startrow & ":" & endrow).Copy


   Sheets("Result").Select
   Range("A1").Select
   ActiveSheet.Paste


   Next rownum
   End With
   End Sub
于 2012-07-11T01:29:18.500 に答える
1

これを試して：

Sub DoEeeeeet(sheetName, termA, termB)

    Dim foundA As Range, _
        foundB As Range
    Dim newSht As Worksheet

    With Sheets(sheetName).Columns(1)
        Set foundA = .Find(termA)
        If Not foundA Is Nothing Then
            Set foundB = .Find(termB, after:=foundA, searchdirection:=xlPrevious)
        End If
    End With

    If foundA Is Nothing Or foundB Is Nothing Then
        MsgBox "Couldn't find " & IIf(foundA Is Nothing, termA, termB)
    Else
        Range(foundA, foundB).Copy
        Set newSht = Sheets.Add
        newSht.Range("B13").PasteSpecial
    End If

End Sub

次のように呼び出すことができます。

DoEeeeeet "Sheet1","Event","Laptop"

「Sheet1」という名前のシートで「Event」の最初のインスタンスと「Laptop」の最後のインスタンスを見つけ、そのすべてのデータを新しいシートの B13 および後続のセルにコピーします。

それはあなたが望むものですか？それとも、"Event" で始まり "Laptop" で終わる各サブ範囲が必要ですか?

于 2012-07-05T06:19:08.280 に答える