【VB】バラバラの行数の文字を結合+追加

質問

Exelのマクロで
ご教授お願いします。

AABB 2012 0219 1111
2222 3333 4444 5555

AABB 2012 0220 1111
2222 3333 4444 5555
6666 7777

AABB 2012 0221 1111
2222

このような、空欄１行を挟んだデータが数十件あります。すべてA列です。
これを・・・

AABB 2012 0219 1111 2222 3333 4444 5555 END

AABB 2012 0220 1111 2222 3333 4444 5555 6666 7777 END

AABB 2012 0221 1111 2222 END

このようにマクロで一行にまとめ,末尾に”END”を追加したいのです。
１つのデータの行数は２行だったり、６行だったりと変則です。
よろしくお願いします。m(__)m

回答No.1

luka3 · ベストアンサー

作ってみました。

Sub test()
　Dim shSrc As Worksheet, shDst As Worksheet

　Set shSrc = Sheets("sheet1") ' 元データのあるシート名
　Set shDst = Sheets("sheet2") ' 連結データを作るシート名

　yDst = 1

　For ySrc = 1 To 10000
　　' 空行の場合
　　If shSrc.Cells(ySrc, 1).Text = "" Then
　　　' ２行続けて空行だったら終了
　　　If shDst.Cells(yDst, 1).Text = "" Then End
　　　' 末尾に END を追加
　　　shDst.Cells(yDst, 1).Value = shDst.Cells(yDst, 1).Text & " END"
　　　yDst = yDst + 2
　　Else ' データがある場合
　　　' １つ目ならそのまま、２つ目以降ならスペースをはさんで結合
　　　If shDst.Cells(yDst, 1).Text = "" Then
　　　　shDst.Cells(yDst, 1).Value = shSrc.Cells(ySrc, 1).Text
　　　Else
　　　　shDst.Cells(yDst, 1).Value = shDst.Cells(yDst, 1).Text & " " & shSrc.Cells(ySrc, 1).Text
　　　End If
　　End If
　Next
End Sub

お礼

試してみたところ希望通りでした。
回答の速さに驚きました、ありがとうございましたm(__)m

回答No.3

tom04

No.2です！
たびたびごめんなさい。
＞すべてA列です。
の部分を見逃していました。

前回のコードは無視してください。
もう一度コードを載せておきます。
Sheet1のデータは1行目からあるとします。

Sub test()
Dim i As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Application.ScreenUpdating = False
ws1.Cells.Copy Destination:=ws2.Cells(1, 1)
For i = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If ws2.Cells(i, 1) <> "" And ws2.Cells(i - 1, 1) <> "" Then
ws2.Cells(i - 1, 1) = ws2.Cells(i - 1, 1) & ws2.Cells(i, 1)
ws2.Cells(i, 1).Delete (xlUp)
End If
Next i
For i = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i, 1) <> "" Then
ws2.Cells(i, 1) = ws2.Cells(i, 1) & "END"
End If
Next i
ws2.Columns(1).AutoFit
Application.ScreenUpdating = True
End Sub

何度も失礼しました。m(_ _)m

お礼

ありがとうございます。
大変勉強になりましたm(__)m

回答No.2

tom04

こんばんは！
一例です。
Sheet1のデータをSheet2に表示するようにしてみました。
標準モジュールにコピー＆ペーストしてマクロを試してみてください。

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
ws1.Cells.Copy Destination:=ws2.Cells(1, 1)
For i = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If ws2.Cells(i, 1) <> "" And ws2.Cells(i - 1, 1) <> "" Then
j = ws2.Cells(i, Columns.Count).End(xlToLeft).Column
Range(ws2.Cells(i, 1), ws2.Cells(i, j)).Copy Destination:= _
ws2.Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
ws2.Rows(i).Delete
End If
Next i
For i = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
If ws2.Cells(i, 1) <> "" Then
ws2.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = "END"
End If
Next i
ws2.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？