並び替えて結合するマクロ

質問

掲載例のように、E列には昇順で結合し、F列にはそのままの順番で結合するマクロをご教示いただけるでしょうか。

要件は2つあります。
1.4行目のように1つでも空白があると、処理しません（E、F列を空白にする）。
2.A～Eは必ず1つ、Fは1つだけのときと2つ出現するときがあります。

回答No.4

imogasi · ベストアンサー

#2です。
エクセルのソートは、データが存在するセル範囲に、結果を返します。
それで元データは（A-C列データ）は、ソート後では、結果では変わらざるを得ません。
その為にデータは退避するコードを入れてあります。元に戻そうか、どちらにしようか迷ったのだが。
質問者は実行結果を見る程度しかできないようだな。各ステップに色色考えて
やった結果というものもあり、これらが判ると、別のやり方もあるという
勉強になると思うのだが。
配列に入れて、自作ソートする方法でも作ったが、質問者には、書いても仕方がないように思うので、略。
ーー修正案
下記の終りの方に１行加えれば仕舞い。
Range("G" & i + 10 & ":I" & i + 10) = ｄｔは多分不要となるだろうが残してある。
ーー
Sub test02()
lr = Range("A100000").End(xlUp).Row
MsgBox lr
For i = 1 To lr
'退避
dt = Range("A" & i & ":C" & i)
Range("G" & i + 10 & ":I" & i + 10) = dt
'--文字列-結合
bl = Application.WorksheetFunction.CountBlank(Range("A" & i & ":C" & i))
If bl = 0 Then
Range("F" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i)
End If
'----- A-C列 列　ソート

'--ブランクセルがあればスキップ
If bl = 0 Then
Range("A" & i & ":C" & i).Sort _
key1:=Range("A" & i), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight, _
key2:=Range("B" & i), Order2:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight, _
key3:=Range("C" & i), Order3:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
'--文字列-結合
Range("E" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i)
End If
'----退避データを元位置へ復元
Range("A" & i & ":C" & i) = dt
Next i
End Sub

補足

ご回答ありがとうございます。いろいろ試してみて、メッセージボックスの数字の意味もわかりました。後学のために配列に入れて、自作ソートする方法もご教示いただけるでしょうか。

回答No.5

imogasi

補足の要求に答えますが、下記コードは、あまり、本やWEBで載っているやり方ではないので、我流で渋々です。
またソートの自作は、やらないように。
下記は隣接交換法（アルゴリズム）のソートのつもり。
Sub test10()
Dim d As Variant
Set awf = Application.WorksheetFunction
For i = 1 To 5
If awf.CountBlank(Range("A" & i & ":C" & i)) = 0 Then 'Rangeが必要
d = Range("A" & i & ": C" & i)
Range("F" & i) = d(1, 1) & d(1, 2) & d(1, 3)
'---ソート
For s = 1 To 3 - 1
For j = 1 To 3 - 1
If d(1, j) < d(1, j + 1) Then '　<はAcendind順を意味する
Else
'--交換
w = d(1, j)
d(1, j) = d(1, j + 1)
d(1, j + 1) = w
End If
Next j
Next s
Range("E" & i) = d(1, 1) & d(1, 2) & d(1, 3)
End If
Next i
End Sub
３列５行の例です。ここを可変化するのは省略。

お礼

隣接交換法ですか。またひとつ勉強になりました。ありがとうございます。

回答No.3

mdmp2

NO.1 です。

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("H1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

これは連続した1行です。コードが長くなって画面に収まらないとき、途中に「 _」(スペース + 半角アンダーバー) を入れて改行します。
エラーが出るのはシート名がSheet1 と違うからではないかと？
" " に実際のシート名を入れるか、ActiveWorkbook.Activesheet. としてみてください。

補足

シート名は「Sheet1」です。ActiveWorkbook.Activesheetとすると、
同じく「実行時エラー438」のメッセージが出て、デバッグを実行すると、
ActiveWorkbook.ActiveSheet("Sheet1").Sort.SortFields.Clear
の行が黄色くマーキングされます。
こちらの環境の問題でしょうか？

回答No.2

imogasi

例データ　A-C列　質問の通り。
B E A
D B F
C A B
B A
F C F
ーー
標準モジュールに
Sub test02()
lr = Range("A100000").End(xlUp).Row
MsgBox lr
For i = 1 To lr
'退避
dt = Range("A" & i & ":C" & i)
Range("G" & i + 10 & ":I" & i + 10) = dt
'--文字列-結合
bl = Application.WorksheetFunction.CountBlank(Range("A" & i & ":C" & i))
If bl = 0 Then
Range("F" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i)
End If
'----- A-C列 列　ソート
'--ブランクセルがあればスキップ
If bl = 0 Then
Range("A" & i & ":C" & i).Sort _
key1:=Range("A" & i), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight, _
key2:=Range("B" & i), Order2:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight, _
key3:=Range("C" & i), Order3:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
'--文字列-結合
Range("E" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i)
End If
Next i
End Sub
ーー
結果　E,F列
ABE BEA
BDF DBF
ABC CAB

CFF FCF
＝＝＝
Range()の表示法で統一した。
列Sortの質問や問題は珍しく、WEB記事もSortでもいろいろありややこしい。
色んなケースで、上記で、誤りなきか、心配だが、テストを十分してみてください。

補足

ご回答ありがとうございます。このマクロで指示通りの並び替えはできますが、元データが移動してしまい、元データのあった場所に並び順が変わった元データが表示されるようになってしまいます。

それとマクロ実行時にメッセージボックスで、数字の「5」が表示されるのはどのような意味があるのでしょうか？　引き続きご教示いただければ幸いです。

回答No.1

m_and_dmp

記録マクロを元に作成したものです。
あまりスマートではありませんが、期待したとおり動きます。
H1～H３ を作業用セルとして使っていますので、不都合であれば別の場所に移動してください。

ーーーーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Macro1()
I = 1
AA:
Range(Cells(I, 1), Cells(I, 3)).Select
BBlank = WorksheetFunction.CountBlank(Selection)
If BBlank > 0 Then GoTo BB
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("H1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("H1:H3")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cells(I, 5).Value = Cells(1, 8).Value & Cells(2, 8).Value & Cells(3, 8).Value
Cells(I, 5).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("H1:H3").Select
Application.CutCopyMode = False
Selection.ClearContents
Cells(I, 6).Value = Cells(I, 1).Value & Cells(I, 2).Value & Cells(I, 3).Value
BB:
If BBlank = 3 Then GoTo CC
I = I + 1
GoTo AA
CC:
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーー

補足

ご回答ありがとうございます。
マクロを実行すると、「実行時エラー438」というメッセージが出て、デバッグを実行すると、下記の2行が黄色にマーキングされています。

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("H1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

ちなみにデータは行単位で構成されています。1行目に「B」「E」「A」とあるので、E列に昇順で結合して「ABE」、F列にそのままの順番で結合して「BEA」となります。2行目に「D」「B」「F」とあるので…という具合です。