エクセル2010のマクロを使った整列の方法

質問

画像の上の状態から、下の状態へ、マクロを使って整列させる方法を教えて下さい。
A列とB列が同じになるようにしたいのです。よろしくお願いします。

回答No.1

keithin · ベストアンサー

＞整列させる方法を教えて下さい。

ふつーに探して置いていくだけです。
ただし簡単のため、最低限Ａ列は昇順に並べてあるとします

sub macro1()
　dim r as long
　dim rx as long
　on error goto errhandle

’念のため
　range("B:C").sort key1:=range("B1"), order1:=xlascending, header:=xlno

　for r = range("B65536").end(xlup).row to 1 step -1
　　rx = application.match(cells(r, "B").value, range("A:A"), 0)
　　cells(r, "B").resize(1, 2).cut cells(rx, "B")
　next r
　exit sub

’念のため
errhandle:
　cells(r, "B").select
　msgbox "NOT FOUND"
end sub

＃もしも、あなたが言いたかったのがもっと単純に「１行ずつ隙間を開けたい」だけなのでしたら
sub macro2()
　dim r as long
　for r = range("B65536").end(xlup).row to 1 step -1
　　cells(r, "B").resize(1, 2).insert shift:=xlshiftdown
　next r
end sub
とするだけです。

回答No.2

K Kazz（@JazzCorp）

'ネタのシートをアクティブにして実行する
'同じシートを書換えると、移動する側の数が多い場合など、後方から処理しても破壊が起きるので、結果は別シートに出す
'NotMatchの場合は、D列にエラーを表示
Option Explicit
Sub Matching()
Const xName_To = "ReLocation"
Const xKey = 1
Const xKey2 = 2
Const xHeads = 1
Dim xSheet As Worksheet
Dim xIndex
Dim xLast As Long
Dim xLast2 As Long
Dim kk As Long
Dim nn As Long
Set xSheet = ActiveSheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(xName_To).Delete
kk = Worksheets.Count
Worksheets.Add After:=Worksheets(Worksheets.Count)
If (Worksheets.Count > kk) Then
Worksheets(Worksheets.Count).Name = xName_To
Else
Exit Sub
End If
With xSheet
xLast = .Cells(Rows.Count, xKey).End(xlUp).Row
xLast2 = .Cells(Rows.Count, xKey2).End(xlUp).Row
Application.CutCopyMode = False
.Columns(xKey).Copy
Worksheets(xName_To).Columns(xKey).PasteSpecial
.Rows(1 & ":" & xHeads).Copy
Worksheets(xName_To).Rows(1).PasteSpecial
For nn = (xHeads + 1) To xLast2
.Cells(nn, xKey2).Offset(0, 2).Value = Empty
If Not IsEmpty(.Cells(nn, xKey2)) Then
xIndex = Application.Match(.Cells(nn, xKey2).Value, .Range(.Cells(xHeads + 1, xKey), .Cells(xLast, xKey)), 0)
If IsError(xIndex) Then
.Cells(nn, xKey2).Offset(0, 2).Value = "ERROR:NotMatch!!"
Else
.Cells(nn, xKey2).Resize(1, 2).Copy Worksheets(xName_To).Cells(xIndex + 1, xKey2)
End If
End If
Next
End With
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub