エクセルVBAマクロを自動作成する無料アプリです。
例として、「２列を並び替えて、同じ値を横に並べる 」VBAマクロを作成します。
事例 A列とB列を、同じ値は横に並べて、並べ替える
できました(^^)/
アプリの設定
アプリの設定です。
アプリへのリンク ⇒２列を並べ替えし、同じ値を横に並べる
【ポイント】
■ 元データの値は、変更を検証できるよう、変更前の状態です。
なお、並べ替えにより、書式がズレることがあります。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ_72() '２列を並べ替えし、同じ値を横に並べる
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止Worksheets("Sheet1").Select
'現状を配列に退避
Dim 旧リスト左 As Variant, 旧リスト右 As Variant
旧リスト左 = Range(Range("a2"), Cells(Rows.Count, Range("a2").Column).End(xlUp)).Value
旧リスト右 = Range(Range("a2").Offset(0, 1), Cells(Rows.Count, Range("B2").Column).End(xlUp)).Value
'並び替え
Range(Range("a2"), Cells(Rows.Count, Range("a2").Column).End(xlUp)).Sort key1:=Range("a2"), order1:=xlAscending, Header:=xlNo
Range(Range("a2").Offset(0, 1), Cells(Rows.Count, Range("a2").Offset(0, 1).Column).End(xlUp)).Sort key1:=Range("a2").Offset(0, 1), order1:=xlAscending, Header:=xlNo
'◆リストに配列を入れる
Dim リスト左 As Variant, リスト右 As Variant
リスト左 = Range(Range("a2"), Cells(Rows.Count, Range("a2").Column).End(xlUp)).Value
リスト右 = Range(Range("a2").Offset(0, 1), Cells(Rows.Count, Range("a2").Offset(0, 1).Column).End(xlUp)).Value
'旧リストを戻す
Range("a2").Resize(UBound(旧リスト左, 1), 1) = 旧リスト左
Range("a2").Offset(0, 1).Resize(UBound(旧リスト右, 1), 1) = 旧リスト右
Erase 旧リスト左
Erase 旧リスト右
'◆値を転記
Dim リスト左行 As Long, リスト右行 As Long, リスト左値 As Variant, リスト右値 As Variant, セル左行 As Long, セル右行 As Long, i As Long
リスト左行 = 1
リスト右行 = 1
セル左行 = 0
セル右行 = 0
Worksheets("Sheet1").Select
Do
'リストの値を取得する
リスト左値 = リスト左(リスト左行, 1)
リスト右値 = リスト右(リスト右行, 1)
'リストの値を比較し、小さいほうをセルに入れ、リスト行に１を足す
If リスト左値 = リスト右値 Then
Range("d2").Offset(セル左行, 0) = リスト左値
Range("d2").Offset(セル右行, 1).Value = リスト右値
セル左行 = セル左行 + 1
セル右行 = セル右行 + 1
リスト左行 = リスト左行 + 1
リスト右行 = リスト右行 + 1
ElseIf リスト左値 < リスト右値 Then
Range("d2").Offset(セル左行, 0).Value = リスト左値
セル左行 = セル左行 + 1
セル右行 = セル右行 + 1
リスト左行 = リスト左行 + 1
ElseIf リスト左値 > リスト右値 Then
Range("d2").Offset(セル右行, 1).Value = リスト右値
セル左行 = セル左行 + 1
セル右行 = セル右行 + 1
リスト右行 = リスト右行 + 1
End If
'左右どちらかが、最後になったら、相手方の残りをセルに入れる
If リスト左行 > UBound(リスト左, 1) Then
For i = リスト右行 To UBound(リスト右, 1)
Range("d2").Offset(セル左行, 1) = リスト右(i, 1)
セル左行 = セル左行 + 1
Next i
Exit Do
ElseIf リスト右行 > UBound(リスト右, 1) Then
For i = リスト左行 To UBound(リスト左, 1)
Range("d2").Offset(セル右行, 0) = リスト左(i, 1)
セル右行 = セル右行 + 1
Next i
Exit Do
End If
Loop
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub
ChatGPTで修正
あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です！
