人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロで、行を入れ替えるプログラムについて質問です。お気持ちだけですが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

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


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

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:ABC def MNO エクセル スタート
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● llusall
●21ポイント

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


手動で行うと、

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

◎質問者からの返答

ありがとうございます。

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

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


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

言い換えると、

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

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

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

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


2 ● nattow
●20ポイント

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

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
◎質問者からの返答

ありがとうございます。

確かに動きました。

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

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


3 ● きゃづみぃ
●100ポイント

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

◎質問者からの返答

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

参考にさせて頂きます。


4 ● Mook
●100ポイント ベストアンサー

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

データ範囲は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

◎質問者からの返答

これは使い易そうです。

早速試してみます。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ