マクロ セルを自動的に結合したい

質問

A列～C列に文字がバラバラ入っています。（多くても50行辺りまで）
文字が入っているセルの下に空白がいくつが並んでいます。
次の文字があるまで文字＋空白をまとめて結合したいのです。
力をお借りできないでしょうか？
宜しくお願いします。

回答No.3

watabe007 · ベストアンサー

>結合したい枠を選択してマクロを実行することは可能でしょうか？
選択範囲を処理します。
Sub Test2()
Dim myRang As Range, 列 As Range, c As Range
Dim Start As Long
Application.DisplayAlerts = False
Set myRang = Selection
For Each 列 In myRang.Columns
Start = myRang.Item(1).Row
For Each c In 列.Cells
If c.Offset(1).Value <> "" Or Intersect(c.Offset(1), myRang) Is Nothing Then
Range(Cells(Start, c.Column), Cells(c.Row, c.Column)).Merge
Start = c.Offset(1).Row
End If
Next
Next
Application.DisplayAlerts = True
End Sub

お礼

ありがとうございます。
この中で一番自由度が高いです。助かりました。

回答No.6

kkkkkm

一番上の行のデータが横並びではない場合、及び選択した1行目ではない場合(この場合選択がデータの行の上の行から選択してしまったなど)、それぞれの列の最初のデータがある行から結合を始めるパターンです。

Sub Example()
Dim i As Long, j As Long, FRow As Long
Dim URange As Range

For i = Columns("A").Column To Columns("C").Column
If Cells(Selection(1).Row, i).Value = "" Then
FRow = Cells(Selection(1).Row, i).End(xlDown).Row
Else
FRow = Cells(Selection(1).Row, i).Row
End If
Set URange = Cells(FRow, i)
For j = FRow To Selection(Selection.Count).Row
Set URange = Union(URange, Cells(j, i))
If Cells(j, i).Offset(1, 0).Value <> "" Or Cells(j, i).Row = Selection(Selection.Count).Row Then
URange.Merge
Set URange = Cells(j, i).Offset(1, 0)
End If
Next j
Next i
Set URange = Nothing
End Sub

お礼

まだ教えていただき、ありがとうございます。

回答No.5

imogasi

自信はありません。
というのも下記例のB1やC1:C2の上から下に、ブランクセルで始まっている場合の、処理方法が質問に書かれていないこと（ため）です。多分気に食わないだろう。
こういう質問は条件を文章化するのが、むつかしいわね。
ーー
他の回答で選択範囲をマウスで選択する場合の補足質問をしているが、その程度のことを聞くなら、改良はおぼつかないだろうから、ニーズに合わない場合はスルーしてください。
ーー
データ例　a1:ｃ２７の３列に、ところどころ数字が入っている例。
1
2
4

2
6
4 4

7
5 4
7

6 9

7
3
8

66 8 5

5
89
56 7

Sub test01()
cc = 2 '色コード
'－－－
For c = 1 To 3 'C列まで
Range(Cells(1, c), Cells(30, c)).MergeCells = False '一旦結合解除
Range(Cells(1, c), Cells(30, c)).Interior.ColorIndex = xlNone '既存の色を抹消
r = 1
s = 1
Do
rw = Cells(s, c).End(xlDown).Row 'Endキー＋下矢印キー↓に相当の動作
MsgBox rw
If rw = Rows.Count Then rw = 31
Range(Cells(s, c), Cells(rw - 1, c)).Merge '直前の行までマージ
m = cc Mod (56 + 1) '順番の色コードを決めている
Range(Cells(s, c), Cells(rw - 1, c)).Interior.ColorIndex = m
cc = cc + 1 '次の色コード
'---
s = rw
Loop While rw < 30 '３０行で下限とする
Next c
End Sub
Sub test02()
For c = 1 To 3
Range(Cells(1, c), Cells(30, c)).MergeCells = False
Range(Cells(1, c), Cells(30, c)).Interior.ColorIndex = xlNone
Next c
End Sub
色も付けてみたが、質問者は、からな邪魔な場合に、コードでの、省き方もわからないようだから、本件回答は徒労か。

お礼

ありがとうございます。
参考にさせていただきます。

回答No.4

kkkkkm

ABC列限定なのでC列以降を間違って選択しても選択した範囲の最終行のABC列だけ対応します。他の回答と違いを出さないとなのでやりかたも変えてます。

Sub Example()
Dim i As Long, j As Long
Dim URange As Range

For i = Columns("A").Column To Columns("C").Column
Set URange = Cells(Selection(1).Row, i)
For j = Selection(1).Row To Selection(Selection.Count).Row
Set URange = Union(URange, Cells(j, i))
If Cells(j, i).Offset(1, 0).Value <> "" Or Cells(j, i).Row = Selection(Selection.Count).Row Then
URange.Merge
Set URange = Cells(j, i).Offset(1, 0)
End If
Next j
Next i
Set URange = Nothing
End Sub

お礼

ありがとうございます。
AからC限定ですね。助かりました。

回答No.2

watabe007

参考に
Sub Test()
　　Dim myRang As Range, 列 As Range, c As Range
　　Dim Start As Long
　　Application.DisplayAlerts = False
　　Set myRang = Range("A1:C9")
　　For Each 列 In myRang.Columns
　　　　Start = 1
　　　　For Each c In 列.Cells
　　　　　　If c.Offset(1).Value <> "" Or Intersect(c.Offset(1), myRang) Is Nothing Then
　　　　　　　　Range(Cells(Start, c.Column), Cells(c.Row, c.Column)).Merge
　　　　　　　　Start = c.Offset(1).Row
　　　　　　End If
　　　　Next
　　Next
　　Application.DisplayAlerts = True
End Sub

お礼

ありがとうございます。
A1:C9と記述してありますが、仮にA1:C30だったりA1:C40だったりとその都度修正するのも手間がかかります。
結合したい枠を選択してマクロを実行することは可能でしょうか？
宜しくお願いします。

回答No.1

kkkkkm

2の下で結合するセルの数はどのように決めているのでしょうか？
> 次の文字があるまで文字＋空白をまとめて結合
なのですから2の下で結合するセルはないと思いますが…。

お礼

コメントありがとうございます。
気付きませんでした。
結合したい枠を選択してからマクロを実行したほうがいいですね？