セル内文字を切り取りその列の空白セルに貼付け

質問

B列3行目から添付のようにセル内にカンマを含む文字がありカンマで区切った文字ごとに切り取り矢印右のように同B列の次の空白行に順に貼り付けたく、その際カンマは削除したいのですが行数が多くてできればVBAコードがお分かりなる方宜しくお願いします。
環境はwindows7 office2013です。

回答No.4

bunjii · ベストアンサー

>その際カンマは削除したいのですが行数が多くてできればVBAコードがお分かりなる方宜しくお願いします。
VBAのコードを記述するにはフローチャートを作成して仕事の流れを定義することが重要です。
フローチャートに沿ってトライ&エラーで確認しながらコードの記述を勧めます。
私なりの解釈でフローチャートを脳裏に浮かべてコーディングすると下記のようになりました。

Sub Sample()
nextrow = 1
Cells(nextrow, 2).Select
Row = 1
Do While Row <= Cells(Rows.Count, 2).End(xlUp).Row
If InStr(Cells(Row, 2), ",") > 0 Then
b = Cells(Row, 2)
Cells(Row, 2) = Left(b, InStr(b, ",") - 1)
nextrow = Cells(nextrow, 2).End(xlDown).Row
If nextrow = Rows.Count Then nextrow = Row
Cells(nextrow + 1, 2) = Mid(b, InStr(b, ",") + 1, Len(b))
End If
Row = Row + 1
Loop
End Sub

処理結果は添付画像のようになります。

回答No.5

imogasi

例データ（質問と少し違うかも９
Ｓｈｅｅｔ１の
Ｂ１：Ｂ７に
ーー
B列
名前
うい,あた

お,え,か

い,きくけ
ーー
標準モジュール
Sub test01()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh2.Range("B1") = "Ｂ列"
sh2.Range("B2") = "名前"
k = 3
lr = Range("B10000").End(xlUp).Row
MsgBox lr
For Each cl In sh1.Range("b3:B" & lr)
If cl = "" Then GoTo p1
MsgBox cl
x = Split(cl, ",")
For i = 0 To UBound(x)
MsgBox x(i)
sh2.Cells(k, "B") = x(i)
k = k + 1
Next
p1:
Next
End Sub
ーー
実行結果
Ｓｈｅｅｔ２のＢ１：Ｂ９
ーー
Ｂ列
名前
うい
あた
お
え
か
い
きくけ

お礼

ありがとうございます。勉強になります。

回答No.3

mt2015

こんな感じでつくってみました。
・データが入っているセルにはカンマ区切りで先頭のデータが残る
・先頭以外のデータは、空セルに順番に入れる

Sub sample()
　　Dim sAbsence() As String
　　Dim vData As Variant
　　nCount = 0
　　For nRow = 3 To Cells(Rows.Count, 2).End(xlUp).Row
　　　　If Cells(nRow, 2) <> "" Then
　　　　　　vData = Split(Cells(nRow, 2), ",")
　　　　　　'データ有セルには先頭データを残す
　　　　　　Cells(nRow, 2) = vData(0)
　　　　　　'2つ目以降のデータを取得
　　　　　　For i = 1 To UBound(vData)
　　　　　　　　ReDim Preserve sAbsence(nCount)
　　　　　　　　sAbsence(nCount) = vData(i)
　　　　　　　　nCount = nCount + 1
　　　　　　Next i
　　　　End If
　　Next nRow

　　'先頭以外のデータを空セルに貼り付け
　　nSelRow = 3
　　For j = 0 To UBound(sAbsence)
　　　　If Cells(nSelRow + 1, 2) <> "" Then
　　　　　　 nSelRow = Cells(nSelRow, 2).End(xlDown).Row + 1
　　　　Else
　　　　　　nSelRow = nSelRow + 1
　　　　End If
　　　　Cells(nSelRow, 2) = sAbsence(j)
　　Next j
End Sub

お礼

ありがとうございます。勉強になります。

回答No.2

山田 太郎（@f_a_007）

添付図のように

１、２行間隔で切り出す。
２、１番目と２番目を切り出す。

というのであれば、VBAコードを書く必要はありません。添付図では、以下の関数を利用しています。しかし、 Excel の関数でも可能だと思います。

で、問題は、冒頭のルールが崩れた場合。まあ、その時は、VBAコードを書くことになるかと・・・。でも、その場合でも CutStr()を利用すればチョイチョイだと思いますよ。なお、CutStr()の使用は次のようです。

? CutStr("AAA,BBB,CCC", ",", 1)
AAA
? CutStr("AAA,BBB,CCC", ",", 2)
BBB
? CutStr("AAA,BBB,CCC", ",", 3)
CCC
? CutStr("AAA,BBB,CCC", ",", 4)

? CutStr("AAA and BBB and CCC", " and ", 1)
AAA
? CutStr("AAA and BBB and CCC", " and ", 2)
BBB

　例外を知っているのは質問者だけ。CutStr()を利用されたらVBAは書けるでしょう。

祈、成功！

Option Explicit

Public Function CutStr(ByVal Text As String, _
　　　　　　　　　　ByVal Separator As String, _
　　　　　　　　　　ByVal N As Integer) As String
　　Dim strDatas() As String

　　strDatas = Split("" & Separator & Text, Separator, , 0)
　　CutStr = strDatas(N * Abs((N <= UBound(strDatas))))
End Function

お礼

ありがとうございます。

回答No.1

SI299792

空白が余った場合、足りない場合のルールが、わかりません。

例えば、B5は３つに分かれているのに、空白が１つしかありません。
この場合、余った「か」はB8に行っています。そのため、
「い，きくけ」が「い，か，きくけ」と変換されているように見えます。

空白が余った場合、足りない場合どうするのか説明して下さい。

お礼

ありがとうございます。