VBAで統合セルの並び替えは可能ですか？

質問

表題のとうりなのですが・・・

Sub 並番号()

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("M4")
.SetRange Range("A4:M242")

　　.Apply
End With

End Sub

とプログラムしてるのですが、M4からM242までがセルを３個ずつ
統合したセルになっております。

統合セルの並び替えは出来ないのでしょうか？

ご教授お願いいたします。

回答No.4

mitarashi

自分でも使いたい場面がありましたので、作成してみました。誤動作するかもしれないので、必ずバックアップを取ってから試してみてください。当方XL2000です。作業シートを作成して、そちらに並べ替えてコピーし、元の範囲に書き戻します。
'選択範囲の１列目（文字列、結合セル対応）をキーに並べ替え
Sub test()
Dim targetRange As Range

If TypeName(Selection) <> "Range" Then Exit Sub
Set targetRange = Selection
Call sortMergeCells(targetRange)
End Sub

Private Sub sortMergeCells(targetRange As Range)
Dim data() As Variant, dataRange() As Range
Dim myCell As Range
Dim i As Long
Dim newSheet As Worksheet
Const sortDirection As Long = 1 '昇順

Application.ScreenUpdating = False
Set myCell = targetRange.Cells(1)
i = 1
Do
ReDim Preserve data(1 To i), dataRange(1 To i)
data(i) = myCell.Value
Set dataRange(i) = myCell.MergeArea.Resize(, targetRange.Columns.Count)
Set myCell = myCell.Offset(1, 0)
i = i + 1
Loop Until Intersect(myCell, targetRange) Is Nothing
Call BubbleSortStrings(data, dataRange, sortDirection)
Set newSheet = Sheets.Add
Set myCell = newSheet.Range("a1")
For i = 1 To UBound(data)
dataRange(i).Copy myCell
Set myCell = myCell.Offset(1, 0)
Next i
newSheet.UsedRange.Copy targetRange.Cells(1)
Application.DisplayAlerts = False
newSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

'Microsoftのバブルソートを改造
'direction 1:昇順、-1 降順
Private Sub BubbleSortStrings(sArray() As Variant, rArray() As Range, direction As Long)
Dim lLoop1 As Long
Dim lLoop2 As Long
Dim lTemp As String
Dim rTemp As Range

For lLoop1 = UBound(sArray) To LBound(sArray) Step -1
For lLoop2 = LBound(sArray) + 1 To lLoop1
If StrComp(sArray(lLoop2 - 1), sArray(lLoop2)) = direction Then
lTemp = sArray(lLoop2 - 1)
Set rTemp = rArray(lLoop2 - 1)
sArray(lLoop2 - 1) = sArray(lLoop2)
Set rArray(lLoop2 - 1) = rArray(lLoop2)
sArray(lLoop2) = lTemp
Set rArray(lLoop2) = rTemp
End If
Next lLoop2
Next lLoop1
End Sub

回答No.3

kenpon24

一応、例1をコーディングしてみました。。
セル結合が3セル限定だし、結合セルが横にも続いていると
意図したとおりに動かないと思われますが、質問の例なら動くんじゃないかと思います。
もっと汎用性を持たせたかったらセルのサーチの際にMergeAreaを考慮して作る必要があると思います。

Sub temp()
Call MGCellSortTest("M4:M242") 'ソートしたい範囲
End Sub
'結合セルのソート (縦限定)
Sub MGCellSortTest(RangeAdrs As String)

Dim RangeHdr As String 'ソートする箇所のヘッダ
Dim TempRange As Range
Dim TempRange2 As Range

RangeHdr = Range(RangeAdrs)(1).Address

'ソート範囲の結合セルを解除する
For Each TempRange In Range(RangeAdrs)

If TempRange.MergeCells = True Then
TempRange.MergeCells = False
End If

'空白だったら１セル上の値を入れておく
If TempRange.Row <> 1 And TempRange = "" Then
TempRange = TempRange.Offset(-1, 0)
End If

Next

'ソート 2007は未テスト
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range(RangeHdr)
.SetRange Range(RangeAdrs)

.Apply
End With

'警告を消す
Application.DisplayAlerts = False

Dim i As Long
Dim col As Integer

col = Range(RangeAdrs).Column

'入力セルの先頭から最終行まで
With Range(RangeAdrs)
For i = .Row To .Rows(.Rows.Count).Row
'次のセルが同じ値だったら３セル分結合する
If Cells(i, col) = Cells(i + 1, col) Then
Range(Cells(i, col), Cells(i + 2, col)).Merge
i = i + 2
End If
Next
End With

Application.DisplayAlerts = True

End Sub

回答No.2

kenpon24

コードを書くのは面倒なのでどういう事をすればいいかを書きます。
例1の方が簡単かな。

例1:
1,まずソートしたい箇所のセル結合を解きます。
2,結合が解除された箇所は先頭を除いて空欄になるので、結合されていた箇所と同じ値を入れます。
3,ソートを実行します。
4,同じ値が入っているセルを3セルずつ？結合しなおします。

例2:
1,バブルソートでもクイックソートでもいいので自前でソート関数を実装します。
2,結合セルから値を取得して配列に格納します。
3,実装したソート関数で並べ替えます。
4,並べ替えた順に元のセルに値を入れます

お礼

回答ありがとうございます。

非常に難しい感じですが挑戦してみます。

回答No.1

neKo_deux

結合したセルは、Sortで並べ替えする事は出来ません。
(最新のExcelとかなら改善されているかも知れませんが。)

マクロで結合したセルの値を入れ替えるユーザー定義関数を作って、並べ替え処理を自作とか。

補足

早速の解答ありがとうございます。

質問ばかりで申し訳ないのですが・・・

総合したセルの値を入れ替えるとはどのようなことでしょうか？

ご教授お願いいたします。