3

OK、私はこれを正しくしようとして髪を引っ張ってきましたが、答えは非常に簡単であるべきだと感じています!

まず、2 つのマクロを作成しました。これらを LeftCut と RightCut と呼びます。これらは 4 列の行を切り取り、シートの別の場所に貼り付けます。これらの VBA コードは次のとおりです。

    Sub RightCut()
ActiveCell.Offset([0], [-1]).Select
Range(ActiveCell, ActiveCell.Offset(0, -3)).Cut
ActiveCell.Offset([0], [6]).Select
Range(ActiveCell, ActiveCell.Offset(0, 3)).Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset([0], [-6]).Select
Range(ActiveCell, ActiveCell.Offset(0, -3)).Select
Selection.Delete Shift:=xlUp
End Sub

   Sub LeftCut
Range(ActiveCell, ActiveCell.Offset(0, 3)).Cut
ActiveCell.Offset([0], [10]).Select
Range(ActiveCell, ActiveCell.Offset(0, 3)).Select
Selection.Insert Shift:=xlDown
ActiveCell.Offset([0], [-10]).Select
Range(ActiveCell, ActiveCell.Offset(0, 3)).Select
Selection.Delete Shift:=xlUp
End Sub

これらはどちらも単独で機能します。今、私がやりたいのはこれらを一緒にループすることです。特定の条件が満たされた場合、たとえば、左の 4 つの列が右の 4 つの列と一致せず、1 つの行を切り取る必要がある場合、これら 2 つのマクロのいずれかが呼ばれた。

今、Do While ループ用に記述された疑似コードがありますが、これは私が探しているものに近いですか? 主な問題は、ワークシートのいくつかのポイントで、最大 20 行をカット アンド ペーストする必要があるため、上記のマクロを ActiveCell = ActiveCell.Offset(0,-1) になるまで繰り返し使用することです。 . これは Do While ループで可能ですか??

Sub HighAce()


Dim i As Long
Dim ActiveCell As Range

i = 2

Application.ScreenUpdating = True

Do While i <= 40043

     Set ActiveCell = Range("E" & i)

    If ActiveCell = ActiveCell.Offset([0], [-1]) Then
     ActiveCell.Offset([1], [0]).Select

    ElseIf ActiveCell > ActiveCell.Offset([0], [-1]) Then
      Application.Run "'Methylation Array.xlsm'!NewBlueCut"

    ElseIf ActiveCell < ActiveCell.Offset([0], [-1]) Then
     Application.Run "'Methylation Array.xlsm'!NewBlueCut"

    Else: Stop

    End If

Loop


 End Sub

私はここで正しい軌道に乗っていますか？行方不明の行はありますか？

どなたでもご協力いただければ幸いです。この問題については、後ほど頭をすっきりさせて、自分で解決策を見つけられるかどうか見てみます。

ありがとう！

編集: サンプル データセット

xxx A01 A01 xxx

xxx A02 A04 xxx

xxx A06 A05 xxx

xxx A07 A06 xxx

xxx A08 A09 xxx

したがって、右上の A01 がアクティブ セルの場合、ActiveCell=ActiveCell.Offset(0,-1) の場合は次の行に移動します。ここで、Active Cell は > 隣接セルなので、Leftcut を行います。さて、Activecell < Adjacent cell なので、RightCut を実行します。別の rightcut はこれら 2 つのセルを等しくするので、カーソルは次の行に移動し、再び移動します。

4

1 に答える 1

1

Peter L.が述べたように、少なくともiループを増やす必要があります。

.Offsetただし、範囲についてもう少し詳しく理解することをお勧めします.Resize。これにより、コードを大幅に削減できます。

ループには次の構成を使用します。

Set rng = Range("E2")
While _condition_
    ...Do something
    Set rng = rng.offset(1)
Wend

私はこの最終的なコードで終わり、カットサブも作り直します：

Sub RightCut(rng As Range)
    rng.Offset(, -4).Resize(, 4).Cut
    rng.Offset(, 5).Resize(, 4).Insert xlDown
    rng.Offset(, -4).Resize(, 4).Delete xlUp
End Sub


Sub LeftCut(rng As Range)
    rng.Resize(, 4).Cut
    rng.Offset(, 10).Resize(, 4).Insert xlDown
    rng.Resize(, 4).Delete xlUp
End Sub

Sub HighAce()
    Dim rng As Range
    Dim lngcount as Long

    Application.ScreenUpdating = True

    Set rng = Range("E2")

    While rng <> "" And rng <> rng.Offset(, -1)
        lngCount = lngCount + 1
        If lngCount > 40000 Then Stop
        If rng > rng.Offset(, -1) Then
            LeftCut rng
        ElseIf rng < rng.Offset(, -1) Then
            RightCut rng
        Else
            lngCount = 1
            Set rng = rng.Offset(1)
        End If

        'This assign the next row

    Wend
 End Sub

データがなく、目的もわからないのでテストはしていませんが、出発点になると思います！

于 2013-02-18T20:55:32.900 に答える