セルを結合する エラーが出る

質問

https://okwave.jp/qa/q9543025.html
でおせわになりました。
●上記の場合、選択範囲を指定よりズレるとエラー1004がでます。
選択範囲が指定と違っていた場合、「選択範囲が違います」といったメッセージを表示するにはどうすれば良いのでしょうか？
●A列の最後尾にエンドを入れることで「最後の空白」と認識するようにしてありますが、A列以外つまり、B列～M列もエンドを入れないとエラーになるようです。A列のみエンドを入れることで「最後の空白」と認識するようにしたいのです。
●A列2行目からだとエラーになります。A列2行目もしくは3行目でも対応するにはどうすれば良いのでしょうか？
お手数ですが、色々とご教鞭を宜しくお願いします。
例
=A2:M21
=A3:M21

回答No.4

watabe007 · ベストアンサー

>列からZ列までデータがあり、セル結合したいのはA列からM列
>最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Columnを
最終列がM列と固定しているのであれば
最終列 = 13

お礼

ありがとうございます。
解決できました。マクロって難しいですね。
watabe007様のようにマスターするには何年かかるかな。

回答No.3

watabe007

>文字を上揃いにするコード
Sub test4()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim 開始行 As Long, 最終行 As Long, 最終列 As Long
　　On Error GoTo ErrorHandler
　　If ActiveSheet.Name = "Sheet1" Then
　　　　開始行 = 2
　　ElseIf ActiveSheet.Name = "Sheet2" Then
　　　　開始行 = 3
　　ElseIf ActiveSheet.Name = "Sheet3" Then
　　　　開始行 = 4
　　End If
　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
　　For 列 = 1 To 最終列
　　　　Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
　　　　Rng.VerticalAlignment = xlTop 'ここに記述してください。
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　Union(ar(1).Offset(-1), ar).Merge
　　　　Next ar
　　Next 列
　　Cells(最終行, "A").ClearContents
ErrorHandler:
　　If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
　　　　"Error Message = " & Err.Description, , "Debug"
End Sub

補足

ありがとうございます。
A列からZ列までデータがあり、セル結合したいのはA列からM列までにしたいですが、このコードでは一気にZ列までマクロ実行するため関係のないセルまで結合してしまいます。
最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Columnを
どう書き換えたら良いでしょうか？

回答No.2

watabe007

Sub test3()
Dim Rng As Range, blanks As Range
Dim ar As Range, 列 As Long
Dim 開始行 As Long, 最終行 As Long, 最終列 As Long

On Error GoTo ErrorHandler
If ActiveSheet.Name = "Sheet1" Then
開始行 = 2
ElseIf ActiveSheet.Name = "Sheet2" Then
開始行 = 3
ElseIf ActiveSheet.Name = "Sheet3" Then
開始行 = 4
End If
最終行 = Cells(Rows.Count, "A").End(xlUp).Row
最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
For 列 = 1 To 最終列
Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
For Each ar In blanks.Areas
Union(ar(1).Offset(-1), ar).Merge
Next ar
Next 列
Cells(最終行, "A").ClearContents

ErrorHandler:
If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
"Error Message = " & Err.Description, , "Debug"
End Sub

補足

ありがとうございます。
文字を上揃いにするコード
Rng.VerticalAlignment = xlTop
これをErrorHandler:のエラーコードの前に記述したのですが、反映されませんでした。

回答No.1

watabe007

>A列以外つまり、B列～M列もエンド
最終行は全列同じとして行います。
>選択範囲が指定と違っていた場合
何を基準に選択範囲が指定の違いが
>A列2行目もしくは3行目でも対応するにはどうすれば良いのでしょうか？
都度、メッセージが出ますまで従って入力してください。
Sub test2()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim LastRow As Long, 開始行 As Variant

　　LastRow = Cells(Rows.Count, "A").End(xlUp).Row
　　開始行 = Application.InputBox("開始行を入力して下さい。", Default:=1, Type:=1)
　　If VarType(開始行) = vbBoolean Then Exit Sub
　　If Cells(開始行, 1) = "" Then
　　　　MsgBox 開始行 & " 目は空白ですので終わります。", 48
　　　　Exit Sub
　　End If
　　For 列 = 1 To 13
　　　　Set Rng = Range(Cells(開始行, 列), Cells(LastRow - 1, 列))
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　Union(ar(1).Offset(-1), ar).Merge
　　　　Next ar
　　Next 列
　　Cells(LastRow, "A").ClearContents
End Sub

補足

ありがとうございます。
●A列以外つまり、B列～M列もエンド
うまくできました。
●A列2行目もしくは3行目でも対応するにはどうすれば良いのでしょうか？
シート1はA2行目、シート2はA3行目といった固定ですので、「都度、メッセージが出ます」ではなくてマクロを変更するだけにしたいのです。
●選択範囲が指定と違っていた場合
　For 列 = 1 To 13
はMセルまでですね。仮にDセルまでを選択した場合、デバックエラーがでます。それをエラー表示したいのですが。