エクセルのマクロで、行を入れ替えるプログラムについて質問です。お気持ちだけですが200ポイント差し上げます。


次のような行が並んでいます。

123 abc
456 def
789 ghi
456 jkl
123 mno
783 pqr

1)2行目からプログラムがスタートします。

自分の行の1列目(2行目1列)を参照し、自分より上の行の1列目に同一文字列があればその行の下へ行ごと(無理ならばその行の1列目から8列分目までだけ)移動する。何もなければ何もしない。

2)1行下に移動して同様の操作を繰り返す

3)1列目が空白の行を見つけたら終了


例えば上の例ならば、123と456が同じ文字列であるため、
123 abc
123 mno
456 def
456 jkl
789 ghi
783 pqr

という出力を得たいです。
操作対象は数千行です。


皆様のお力を貸して下さい。よろしくお願いします。

回答の条件
  • 1人2回まで
  • 登録:2006/09/30 00:42:10
  • 終了:2006/10/01 07:21:03

ベストアンサー

id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912006/09/30 13:03:12

ポイント100pt

行の挿入削除を繰り返すと、環境によっては動作も不安定になりますし速度も遅いので、データの切り貼りで実行しました。

データ範囲は8列まででよいとのことでしたが、足りないようでしたら、Resize の8を変更してください。

'-----------------------------------------------------------
Sub customSort()
'-----------------------------------------------------------
    Dim dstWS As Worksheet
    Set dstWS = ActiveSheet
    
    Application.ScreenUpdating = False
    dstWS.Copy after:=dstWS
    Dim tmpWS As Worksheet
    Set tmpWS = ActiveSheet
    
    Dim lastRow As Long
    lastRow = dstWS.Range("A1").End(xlDown).Row

    dstWS.Range("A1:H" & lastRow).Value = ""
    Dim searchStartLine As Long
    Dim writeLine As Long
    writeLine = 1
    Do
        searchStartLine = getStartLine(tmpWS, lastRow)
        If searchStartLine < 0 Then
            Exit Do
        End If
        writeLine = myCollection(dstWS, writeLine, tmpWS, searchStartLine, lastRow)
    Loop While True
    Application.DisplayAlerts = False
    tmpWS.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

'-----------------------------------------------------------
Function getStartLine(tmpWS As Worksheet, lastRow&) As Long
'-----------------------------------------------------------
    For i = 1 To lastRow
        If tmpWS.Cells(i, "A") <> "" Then
            getStartLine = i
            Exit Function
        End If
    Next
    getStartLine = -1
End Function
'-----------------------------------------------------------
Function myCollection(dstWS As Worksheet, writeLine&, _
                     tmpWS As Worksheet, startLine&, lastLine&) As Long
'-----------------------------------------------------------
    Dim searchWord As String
    searchWord = tmpWS.Cells(startLine, "A").Value
    dstWS.Range("A" & writeLine).Resize(1, 8).Value = tmpWS.Range("A" & startLine).Resize(1, 8).Value
    writeLine = writeLine + 1
    tmpWS.Cells(startLine, "A").Value = ""
    
    For i = startLine + 1 To lastLine
        If tmpWS.Cells(i, "A").Value = searchWord Then
            dstWS.Range("A" & writeLine).Resize(1, 8).Value = tmpWS.Range("A" & i).Resize(1, 8).Value
            writeLine = writeLine + 1
            tmpWS.Cells(i, "A").Value = ""
        End If
    Next
    myCollection = writeLine
End Function

id:ReoReo7

これは使い易そうです。

早速試してみます。

2006/10/01 01:03:15

その他の回答(3件)

id:llusall No.1

llusall回答回数505ベストアンサー獲得回数612006/09/30 00:57:01

ポイント21pt

「並べ替えをする」ということでしょうか?


手動で行うと、

1.A1セルを選択

2.メニューの[データ]-[並べ替え]を押下します。

3.最優先されるキーを[列A]。昇順にセットします。

    データ範囲の先頭行は、[データ]にしておきます。

4.OKボタンを押下すると、並べ替えられます。

また、マクロで行うと、次のようになります。

    Columns("A:B").Select

    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _

        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

        SortMethod:=xlPinYin, DataOption1:=xlSortNormal

id:ReoReo7

ありがとうございます。

並べ替えですが、入れ替えではありません。

ある行を別の行の下に挿入して、元あった場所の行は削除される操作です。


さらに対象が数千行に及んでいるので、手動ではなく自動でこれを行います。

言い換えると、

「ある行(1)より上にあって、行(1)の1列目とその行の1列目が一致する行」(2)を見つけて

「(2)の下に(1)を挿入し」

「(1)の一段下の行に対して同様の操作を施す」

ようなプログラムを望んでいます。

2006/09/30 01:10:13
id:nattow No.2

nattow回答回数102ベストアンサー獲得回数272006/09/30 01:18:09

ポイント20pt

簡単な動作確認しかしていませんが・・・。

Sub test()
i = 1
Do Until Cells(i, 1) = ""
    cnt = 1
    j = i + 1
    Do Until Cells(j, 1) = ""
        If Cells(i, 1) = Cells(j, 1) Then
            Rows(j & ":" & j).Select
            Selection.Cut
            Rows(i + cnt & ":" & i + cnt).Select
            Selection.Insert Shift:=xlDown
            cnt = cnt + 1
        End If
        j = j + 1
    Loop
    i = i + cnt
Loop
End Sub
id:ReoReo7

ありがとうございます。

確かに動きました。

しかしとても遅いです100行(50行が2セットで、それぞれ同じ行が2つずつある)に対して実行したところ、1つ入れ替えるのに10秒はかかっています。

早くなれば使えそうなのですが・・・。

2006/09/30 02:05:19
id:taknt No.3

きゃづみぃ回答回数13539ベストアンサー獲得回数11982006/09/30 06:44:33

ポイント100pt

nattowさんのが 遅いということなので、ちょっと速くしてみました。

あと、同じ列が並んでる場合 エラーとなるようなので そこを 修正しました。

Sub test()

i = 1

Range("C1") = Time()

Do Until Cells(i, 1) = ""

cnt = 1

j = i + 1

Do Until Cells(j, 1) = ""

If Cells(i, 1) = Cells(j, 1) Then

If j <> i + cnt Then

Rows(j & ":" & j).Cut

Rows(i + cnt & ":" & i + cnt).Insert Shift:=xlDown

End If

cnt = cnt + 1

End If

j = j + 1

Loop

i = i + cnt

Loop

End Sub

id:ReoReo7

ご丁寧に、どうもありがとうございます。

参考にさせて頂きます。

2006/10/01 01:03:01
id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912006/09/30 13:03:12ここでベストアンサー

ポイント100pt

行の挿入削除を繰り返すと、環境によっては動作も不安定になりますし速度も遅いので、データの切り貼りで実行しました。

データ範囲は8列まででよいとのことでしたが、足りないようでしたら、Resize の8を変更してください。

'-----------------------------------------------------------
Sub customSort()
'-----------------------------------------------------------
    Dim dstWS As Worksheet
    Set dstWS = ActiveSheet
    
    Application.ScreenUpdating = False
    dstWS.Copy after:=dstWS
    Dim tmpWS As Worksheet
    Set tmpWS = ActiveSheet
    
    Dim lastRow As Long
    lastRow = dstWS.Range("A1").End(xlDown).Row

    dstWS.Range("A1:H" & lastRow).Value = ""
    Dim searchStartLine As Long
    Dim writeLine As Long
    writeLine = 1
    Do
        searchStartLine = getStartLine(tmpWS, lastRow)
        If searchStartLine < 0 Then
            Exit Do
        End If
        writeLine = myCollection(dstWS, writeLine, tmpWS, searchStartLine, lastRow)
    Loop While True
    Application.DisplayAlerts = False
    tmpWS.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

'-----------------------------------------------------------
Function getStartLine(tmpWS As Worksheet, lastRow&) As Long
'-----------------------------------------------------------
    For i = 1 To lastRow
        If tmpWS.Cells(i, "A") <> "" Then
            getStartLine = i
            Exit Function
        End If
    Next
    getStartLine = -1
End Function
'-----------------------------------------------------------
Function myCollection(dstWS As Worksheet, writeLine&, _
                     tmpWS As Worksheet, startLine&, lastLine&) As Long
'-----------------------------------------------------------
    Dim searchWord As String
    searchWord = tmpWS.Cells(startLine, "A").Value
    dstWS.Range("A" & writeLine).Resize(1, 8).Value = tmpWS.Range("A" & startLine).Resize(1, 8).Value
    writeLine = writeLine + 1
    tmpWS.Cells(startLine, "A").Value = ""
    
    For i = startLine + 1 To lastLine
        If tmpWS.Cells(i, "A").Value = searchWord Then
            dstWS.Range("A" & writeLine).Resize(1, 8).Value = tmpWS.Range("A" & i).Resize(1, 8).Value
            writeLine = writeLine + 1
            tmpWS.Cells(i, "A").Value = ""
        End If
    Next
    myCollection = writeLine
End Function

id:ReoReo7

これは使い易そうです。

早速試してみます。

2006/10/01 01:03:15
  • id:ReoReo7
    同様の結果が得られるならばルーチンは違っていても構いません。
  • id:Mook
    行の挿入削除を繰り返すと、環境によっては動作も不安定になりますし速度も遅いので、データの移動で実装した例を回答しました。

    本当は配列を使うともっと早いのですが、データ量が大きいのと、メモリなどの環境がわからなかったので、とりあえず今回はシートを利用しています。
  • id:nattow
    申し訳ありません。
    今日改めてデータ量と種類を変更してテストしたところ、私の回答のソースではうまくいかないケースがありました。
    また、id:Mookさんの言われるように、シートを直接操作するとパフォーマンスなどの問題もあります。
    というわけで、私の回答は捨ててください。

    おまけ:
    今回のケースに限らず、シートを直接操作する場合、マクロの先頭に
    Application.ScreenUpdating = False
    最後に
    Application.ScreenUpdating = True
    をつけるだけで、描画をしなくなる分劇的にパフォーマンスが変わることがあります。(すでにご存知でしたらすいません。)
    私の今回の回答のようなマクロの場合、かなり影響があると思います。
  • id:ReoReo7
    メモリは512MBです。
    丁寧なご回答をありがとうございました。

    また、私はマクロをあまり知らないので
    Application.ScreenUpdatingの操作も大変参考になりました。
    ありがとうございました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません