複数列のセル内改行位置でセルを分割する方法

質問

エクセルVBAで下記のように複数列にセル内改行があった時に
1改行を1行として分割をしたい場合、

【A列】
a1作業日(項目名）
ａ2（改行あり）
2013/4/1
2013/4/3

a3（改行なし）
2013/4/1

a4（改行あり）
2013/4/1
2013/4/2

【B列】
b1終了日（項目名）
b2（改行あり）
2013/4/2
2013/4/10

b3（改行なし）
2013/4/2

b4（改行あり）
2013/4/15
2013/4/20

　　　　　　　　　↓

　　 A 列 B列
　　　作業日 終了日
1行目 2013/4/1 2013/4/2
2行目 2013/4/3 2013/4/10
3行目 2013/4/1 2013/4/2
4行目 2013/4/11 2013/4/15
5行目 2013/4/16 2013/4/20

としたいとき、何か良い方法はありますでしょうか？
よろしくお願いいたします。

回答No.7

cj_mover · ベストアンサー

' ' 注）セル内に無駄な改行がある場合はEmpty値と看做されます。
Sub Re8024419_3()
　　Const SMSG = "空白セルがあります。$このマクロは空白セルがある場合は機能しません。$" _
　　　　　　　　& "　空白セルに ""- 空 -"" を埋めて継続する場合は　OK$" _
　　　　　　　　& "　このまま終了する場合は　キャンセル"
　　Dim mtxP, vTmp, v
　　Dim rngS As Range, rngP As Range, rngBlank As Range, r As Range
　　Dim tnRows As Long, tnCols As Long
　　Dim cnR As Long, cnLines As Long, cnLTmp As Long, cnC As Long
　　Dim i&, j&
　　Set rngS = Sheets("Sheet3").Range("A1").CurrentRegion ' シート名指定！
　　On Error Resume Next
　　Set rngBlank = rngS.SpecialCells(xlCellTypeBlanks)
　　On Error GoTo 0
　　If Not rngBlank Is Nothing Then
　　　　If MsgBox(Replace(SMSG, "$", vbLf), vbOKCancel + vbInformation + vbDefaultButton2) = vbOK Then
　　　　　　rngBlank.Value = "- 空 -"
　　　　Else
　　　　　　Exit Sub
　　　　End If
　　End If
　　Set rngP = Sheets.Add.Range("A1") ' = Sheet4.Range("A1") '
　　tnRows = rngS.Rows.Count
　　tnCols = rngS.Columns.Count
　　ReDim mtxP(1 To tnRows * 3, 1 To tnCols)
　　cnR = 1
　　cnC = 0
　　For Each r In rngS
　　　　cnC = cnC + 1
　　　　vTmp = r.Value
　　　　cnLines = 0
　　　　If InStr(vTmp, vbLf) > 0 Then
　　　　　　vTmp = Split(vTmp, vbLf)
　　　　　　For Each v In vTmp
　　　　　　　　mtxP(cnR + cnLines, cnC) = v
　　　　　　　　cnLines = cnLines + 1
　　　　　　Next
　　　　Else
　　　　　　cnLines = 1
　　　　　　mtxP(cnR, cnC) = vTmp
　　　　End If

　　　　If cnC = 1 Then
　　　　　　cnLTmp = cnLines
　　　　Else
　　　　　　If cnLines > cnLTmp Then cnLTmp = cnLines
　　　　End If
　　　　If cnC = tnCols Then
　　　　　　cnR = cnR + cnLTmp
　　　　　　cnC = 0
　　　　End If
　　Next
　　For i = 2 To cnR - 1
　　　　For j = 1 To tnCols
　　　　　　If IsEmpty(mtxP(i, j)) Then mtxP(i, j) = mtxP(i - 1, j)
　　　　Next j
　　Next i
　　rngP.Resize(cnR - 1, tnCols).Value = mtxP
　　Set rngS = Nothing:　　Set rngP = Nothing
End Sub

お礼

非常に丁寧に対応していただきましてありがとうございました。自分の力だけではどうしようもなく、本当に助かりました。感謝感激です。

回答No.6

K Kazz（@JazzCorp）

セル内の改行を直接処理し、数も２つ限定ではなく任意の数を想定しているので、ソコから先の位置合わせ、数合わせ、的なお仕事には、関知しません、、、
例えば、Max２個、下だけが欠けているとか、限定条件であれば、
最終フェーズのオマケ処理にあるような、空行削除みたいなやり方でのフォローは十分可能でヒョウ、、、
xLast = .UsedRange.Rows.Count
For nn = xLast To (xHeads + 1) Step -1
If (Application.WorksheetFunction.CountA(.Rows(nn)) = 0) Then
.Rows(nn).Delete
End If
Next

回答No.5

cj_mover

失礼、１ヶ所ミスりました。＃４は破棄してください。
＃元のシートの■！シート名を指定！■しないと動きません

Sub Re8024419j()
　　Dim vTmp
　　Dim mtxP
　　Dim v
　　Dim rngS As Range
　　Dim rngP As Range
　　Dim rCol As Range
　　Dim r As Range
　　Dim cnRows As Long
　　Dim cnLines As Long
　　Dim cnTmp
　　Dim cnCols As Long

　　Set rngS = Sheets("シート名").Range("A2").CurrentRegion.Resize(, 2) ' ■！シート名を指定！■
　　Set rngP = Sheets.Add.Range("A:B")
　　ReDim mtxP(1 To rngS.Rows.Count * 3, 1 To 2)

　　cnRows = 1
　　For Each r In rngS
　　　　cnCols = r.Column
　　　　vTmp = r.Value
　　　　cnLines = 0
　　　　If InStr(vTmp, vbLf) > 0 Then
　　　　　　vTmp = Split(vTmp, vbLf)
　　　　　　For Each v In vTmp
　　　　　　　　mtxP(cnRows + cnLines, cnCols) = v
　　　　　　　　cnLines = cnLines + 1
　　　　　　Next
　　　　Else
　　　　　　cnLines = 1
　　　　　　mtxP(cnRows, cnCols) = vTmp
　　　　End If
　　　　If cnCols = 1 Then
　　　　　　cnTmp = cnLines
　　　　Else
　　　　　　If cnLines > cnTmp Then cnTmp = cnLines
　　　　　　cnRows = cnRows + cnTmp
　　　　End If
　　Next
　　rngP.Resize(cnRows-1).Value = mtxP
　　Set rngS = Nothing:　　Set rngP = Nothing
End Sub

補足

何度も同じような質問をしてしまい申し訳ございません。

更に質問ですが、
開始日が2日（2行）あるのに対し、終了日が1日（1行）の場合、
対応者・終了日を開始日にあわせて2行それぞれに反映させる方法があれば教えてください。
※現状、1セル2改行までとなっています。

よろしくお願いいたします。

【A列】
a1作業日(項目名）
ａ2（改行あり）
2013/4/1
2013/4/3

a3（改行なし）
2013/4/1

a4（改行あり）
2013/4/1
2013/4/2
※開始日は2日

【B列】
b1対応者(項目名）
b2（改行あり）
Aさん
Bさん

b3（改行なし）
Cさん

b4
Dさん（改行なし）

【C列】
c1終了日（項目名）
c2（改行あり）
2013/4/2
2013/4/10

c3（改行なし）
2013/4/2

c4（改行なし）
2013/4/15
※終了日は1日のみ

　　　　　　　　　↓

　　 A 列 B列 C列
作業日 対応者 完了日
1行目 2013/4/1 Aさん 2013/4/2
2行目 2013/4/3 Bさん 2013/4/10
3行目 2013/4/1 Cさん 2013/4/2
4行目 2013/4/1 Dさん 2013/4/15※
5行目 2013/4/2 Dさん 2013/4/15※

※終了日は対応者が1人で1日ですが、2行に分割された際
　2行ともに同一の人・終了日が反映される。

回答No.4

cj_mover

Sub Re8024419j()
　　Dim vTmp
　　Dim mtxP
　　Dim v
　　Dim rngS As Range
　　Dim rngP As Range
　　Dim rCol As Range
　　Dim r As Range
　　Dim cnRows As Long
　　Dim cnLines As Long
　　Dim cnTmp
　　Dim cnCols As Long

　　Set rngS = Sheets("シート名").Range("A2").CurrentRegion.Resize(, 2) ' ■！適宜指定！■ ' シート名
　　Set rngP = Sheets.Add.Range("A:B")
　　ReDim mtxP(1 To rngS.Rows.Count * 3, 1 To 2)

　　cnRows = 1
　　For Each r In rngS
　　　　cnCols = r.Column
　　　　vTmp = r.Value
　　　　cnLines = 0
　　　　If InStr(vTmp, vbLf) > 0 Then
　　　　　　vTmp = Split(vTmp, vbLf)
　　　　　　For Each v In vTmp
　　　　　　　　mtxP(cnRows + cnLines, cnCols) = v
　　　　　　　　cnLines = cnLines + 1
　　　　　　Next
　　　　Else
　　　　　　cnLines = 1
　　　　　　mtxP(cnRows, cnCols) = vTmp
　　　　End If
　　　　If cnCols = 1 Then
　　　　　　cnTmp = cnLines
　　　　Else
　　　　　　If cnTmp > cnLines Then cnTmp = cnLines
　　　　　　cnRows = cnRows + cnTmp
　　　　End If
　　Next
　　rngP.Resize(cnRows-1).Value = mtxP
　　Set rngS = Nothing:　　Set rngP = Nothing
End Sub

回答No.3

K Kazz（@JazzCorp）

Option Explicit
Sub セルを改行で分割()
Const xName = "Sheet119" '出力シート名
Const xCol_From = 1 '処理対象列番号（From）
Const xCol_To = 2 '処理対象列番号（To）
Const xHeads = 1 'ヘッダ（見出し）行数
Dim xSheet As Worksheet
Dim xPart As Variant
Dim xLast As Long
Dim xRow As Long
Dim jj As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Set xSheet = ActiveSheet
Worksheets(xName).Delete
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = xName
With Worksheets(xName)
Application.CutCopyMode = False
xSheet.Rows(1).Resize(xHeads).Copy
.Rows(1).PasteSpecial
'xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
xLast = xSheet.UsedRange.Rows.Count
For nn = (xHeads + 1) To xLast
Application.CutCopyMode = False
mm = .UsedRange.Rows.Count + 1
xSheet.Rows(nn).Copy
.Cells(mm, "A").PasteSpecial
xRow = mm
For kk = xCol_From To xCol_To
mm = xRow
xPart = Split(xSheet.Cells(nn, kk).Value, vbLf)
If (UBound(xPart) > 0) Then
For jj = 0 To UBound(xPart)
.Cells(mm, kk).Value = Application.WorksheetFunction.Clean(xPart(jj))
Debug.Print .Cells(mm, kk).Address & "：" & .Cells(mm, kk).Value & "：" & jj & "/" & UBound(xPart)
mm = mm + 1
Next
Else
' .Cells(mm, kk).Value = xSheet.Cells(nn, kk).Value
End If
Next
Next
xLast = .UsedRange.Rows.Count
For nn = xLast To (xHeads + 1) Step -1
If (Application.WorksheetFunction.CountA(.Rows(nn)) = 0) Then
.Rows(nn).Delete
End If
Next
xLast = .UsedRange.Rows.Count
.Rows((xHeads + 1) & ":" & xLast).AutoFit
End With
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

補足

1度に質問せずに申し訳ございません。

更に質問ですが、
開始日が2日（2行）あるのに対し、終了日が1日（1行）の場合、終了日を開始日にあわせて2行それぞれに反映させる方法があれば教えてください。
よろしくお願いいたします。

【A列】
a1作業日(項目名）
ａ2（改行あり）
2013/4/1
2013/4/3

a3（改行なし）
2013/4/1

a4（改行あり）
2013/4/1
2013/4/2
※開始日は2日

【B列】
b1終了日（項目名）
b2（改行あり）
2013/4/2
2013/4/10

b3（改行なし）
2013/4/2

b4（改行なし）
2013/4/15
※終了日は1日のみ

　　　　　　　　　↓

　　 A 列 B列
　　　作業日 終了日
1行目 2013/4/1 2013/4/2
2行目 2013/4/3 2013/4/10
3行目 2013/4/1 2013/4/2
4行目 2013/4/11 2013/4/15※
5行目 2013/4/16 2013/4/15※
※終了日が1日ですが、2行に分割された際
　2行ともに同一の終了日が反映される。

回答No.2

keithin

割とベタな手で。

Sub macro1()
　Dim c As Long
　Dim r As Long
　Dim d()
　Dim x

　For c = 1 To Range("IV1").End(xlToLeft).Column
　　ReDim d(0)
　　d(0) = Cells(1, c)
　　For r = 2 To Cells(65536, c).End(xlUp).Row
　　　For Each x In Split(Cells(r, c), vbLf)
　　　’要素を１つずつ配列に拾っていく
　　　　ReDim Preserve d(UBound(d) + 1)
　　　　d(UBound(d)) = x
　　　Next
　　Next r
　　Cells(1, c).Resize(UBound(d) + 1, 1) = Application.Transpose(d)
　Next c
End Sub

回答No.1

cj_mover

こんにちは。

For Each ... Next ループで統一してみました。

一応、各列の行数に不整合があったりしても各列でコンプリートします。

動作確認できたら
　Application.ScreenUpdating = False
など、自信のある範囲で追記してみるのもアリと思います。

Sub Re8024419c()
　　Dim vTmp ' ソースのセル範囲、各セルの値、または値配列
　　Dim v ' 配列変数の各値
　　Dim rngS As Range ' ソースのセル範囲
　　Dim rngP As Range ' 出力先のセル範囲（左上のセルのみ参照）
　　Dim rCol As Range ' ソースのセル範囲、各列
　　Dim r As Range ' ソースのセル範囲、各セル
　　Dim cnRows As Long ' 出力先のセル、相対的行位置
　　Dim cnCols As Long ' 出力先のセル、相対的列位置

　　Set rngS = Range("A1:B6") ' ■！適宜指定！■ ' ソース
　　Set rngP = Range("D1") ' ■！適宜指定！■ ' 出力先
　　cnCols = 0
' ' 　　Application.ScreenUpdating = False
　　For Each rCol In rngS.Columns
　　　　cnCols = cnCols + 1 ' 出力先の列をカウント
　　　　cnRows = 0
　　　　For Each r In rCol.Cells
　　　　　　vTmp = r.Value
　　　　　　If InStr(vTmp, vbLf) > 0 Then ' セル内改行が見つかれば
　　　　　　　　vTmp = Split(vTmp, vbLf) ' セル内改行を区切り文字にした配列
　　　　　　　　For Each v In vTmp
　　　　　　　　　　cnRows = cnRows + 1 ' 出力先の行をカウント
　　　　　　　　　　rngP(cnRows, cnCols) = v ' 出力
　　　　　　　　Next
　　　　　　Else
　　　　　　　　cnRows = cnRows + 1 ' 出力先の行をカウント
　　　　　　　　rngP(cnRows, cnCols) = vTmp ' 出力
　　　　　　End If
　　　　Next r
　　Next
　　Set rngS = Nothing:　　Set rngP = Nothing
End Sub