次のような行が並んでいます。
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
という出力を得たいです。
操作対象は数千行です。
皆様のお力を貸して下さい。よろしくお願いします。
行の挿入削除を繰り返すと、環境によっては動作も不安定になりますし速度も遅いので、データの切り貼りで実行しました。
データ範囲は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
「並べ替えをする」ということでしょうか?
手動で行うと、
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)の一段下の行に対して同様の操作を施す」
ようなプログラムを望んでいます。
簡単な動作確認しかしていませんが・・・。
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秒はかかっています。
早くなれば使えそうなのですが・・・。
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
ご丁寧に、どうもありがとうございます。
参考にさせて頂きます。
行の挿入削除を繰り返すと、環境によっては動作も不安定になりますし速度も遅いので、データの切り貼りで実行しました。
データ範囲は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
これは使い易そうです。
早速試してみます。
これは使い易そうです。
早速試してみます。