ここから本文です

連続した同一セルの結合方法

このエントリーをはてなブックマークに追加

質問者

rudoruhutoさん

2007/9/2114:52:56

連続した同一セルの結合方法

いつもお世話になっております。
また、エクセルの質問で恐縮なのですが、お知恵をお貸しください。

データ集計で表を整える時、連続した同一のセルの結合をよく使うのですがセル数が多い時には、
とても時間がかかります。
(ある時などは、データ抽出に30分。表を整えるのに2時間近くもかかりました(T T))
列ごとに、同一セルを自動的にセル結合するようにできる方法はありますでしょうか?
(マクロ&VBAでも構いません)

(例)例えば下のような表があった場合、

A列 B列
1 a
1 a
1 b
1 b
2 c
2 c
2 d
1 d
1 a

これを、
A列 B列
1 a

 b

2 c

 d
1
 a

といったように、A列で同じセルが連続しているものだけを結合して欲しいです。
(例にもあるように、A列に離れて同じセルの数値が入っている時もあります)
説明がわかりづらくですみませんが、よろしくお願いします。


例では、便宜上簡単な数値にしてありますが、実際はこれが約300行(シートごとに行数も違います)×20シートで
現状は、手作業でドラッグしながらセル結合をしています。
手作業なので、ドラッグのし間違いなどもありそうで困っています。

閲覧数:
5,016
回答数:
1
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

2007/9/2120:46:23

たたき台にして下さい。

ご存知かとは思いますがVBAはやり直しがききませんので、該当するBOOKをコピーして、コピーの方でテストしてください。

B列の結合の条件の解釈が違うかもしれません。
>A列で同じセルが連続しているものだけを結合して欲しいです。
と書かれていますが、
A列 B列
1 a

 b

2 c

 d
1 ←ココもdの結合でよろしいですか?
 a

---------------------------------------------------

Sub Test2()
Dim Ws As Worksheet
Dim Data_Start_Cell As Range
Dim Data_Last_Cell As Range

Dim Start_Cell As Range
Dim c As Variant
Dim myFlg As Boolean

Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'各シートごとに繰り返す
For Each Ws In ThisWorkbook.Worksheets
myFlg = False

'最初のセルの位置を適宜変更して下さい。
Set Data_Start_Cell = Ws.Range("A2")

Set Data_Last_Cell = Ws.Range("A65536").End(xlUp)

'A列
Set Start_Cell = Data_Start_Cell

For Each c In Data_Start_Cell.Resize(Data_Last_Cell.Row - Data_Start_Cell.Row + 1)
If c.Value = c.Offset(1).Value Then
'c対象セルとひとつ下のセルが同じなら、フラグをTrueに
myFlg = True
Else
'c対象セルとひとつ下のセルがが違うときの処理
If myFlg = True Then
'フラグがTrueだったら結合する
Start_Cell.Resize(c.Row - Start_Cell.Row + 1).Merge
myFlg = False
End If
Set Start_Cell = c.Offset(1)
End If
Next

'B列
Set Start_Cell = Data_Start_Cell.Offset(, 1)
myFlg = False

For Each c In Data_Start_Cell.Offset(, 1).Resize(Data_Last_Cell.Row - Data_Start_Cell.Row + 1)
If c.Value = c.Offset(1).Value Then
myFlg = True
Else
If myFlg = True Then
Start_Cell.Resize(c.Row - Start_Cell.Row + 1).Merge
myFlg = False
End If
Set Start_Cell = c.Offset(1)
End If
Next

Next

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

質問した人からのコメント

2007/9/24 22:06:34

降参 ありがとうございます。
頂いたVBAを基本にアレンジして頑張ってみます!!

ちょい足しを取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル
  • このエントリーをはてなブックマークに追加

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

ID/ニックネームを選択し、「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問や知恵ノートは選択されたID/ニックネームのMy知恵袋で確認できます。

ほかのID/ニックネームで利用登録する