EXCEL2010のVBA(マクロ)でカンマ区切りの値を基準に変換する方法

質問
　EXCEL2010のVBA(マクロ)を使用して、ある項目のカンマ区切りされているセルが複数行あり
　カンマ区切りされている値ごとに行に変換する。

内容
①sheet1には各項目ごとに値があります。
　Name2項目の値はカンマ区切りされいて、Name1項目の値が同一であれば、
　複数行にカンマ区切りの値がありますが、Name1項目は最初の行だけの値表示で
　複数行になった場合の2行目以降は空白となっています。(同様にNo項目も)
②ここでVBA(マクロ)を使用して、Name2をキーとして【sheet2】に
　1 vs カンマ区切り複数値　→　1 vs 1 で書き出す。
③変換後はCount項目は不要になります。
④Info1以降の項目については、Name1項目が同一であれば同一の値になります。
⑤最終行から2行の空白行を保って、集計関係で必要な3行があり、同じ空白行を保って
　sheet2にも必要になります。
⑥sheet1のカンマ区切りで、行最後にカンマが無い場合もあります。(赤線部)

と言う内容になります。
現在、VBAにするにはハードルが高く手作業で行っており時間短縮したくて
ここで質問させて頂きました。

どなたか教えて頂けないでしょうか？
よろしくお願いいたします。

質問者からの補足コメント

• 追加画像を見てください。
  (画像を拡大しました)
  
  あと赤枠で囲った部分はシート１では先に存在している物なのですよね？
  回答) はい、その通りです。
  
  要は行の一番下から上に向かって最終行を求める事は厳しいとみてよいですか？
  回答) はい、そのようになります。
  　　　VBAで可能かどうか判らないのですが、Name2項目のセル値を基準に
  　　　最終行を求めて、その最終行から空白2行を保って3行目から6行目を
  　　　コピー抽出できるのであれば良いのですが・・・。
  
  またName1のNo1が空白になる事はありませんか？
  回答) はい、それはありません。

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2020/05/09 23:16

• 付けた画像が小さいので、再度UP致します。

  
    補足日時：2020/05/09 23:25

No.7 ベストアンサー 回答者： tom04 回答日時： 2020/05/10 11:38

No.2です。

拡大された画像を見ると
＞Sheet1のC列には文字列の最後にカンマがある場合とない場合があるのですね。

前回のコードに少し手を加えてください。
尚、今回も両シートをも1行目は項目行でデータは2行目以降のA列からとします。

前回のコードの
＞With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
の前に
＞If myAry1(k) <> "" Then
を追加

＞End With　←　（.Offset(, 5) = myAry2(2)　の次の行です）
の次に
＞End If
を追加してみてください。m(_ _)m

この回答へのお礼

改善策ありがとうございます。
大変、助かります。

お礼日時：2020/05/11 16:56

No.10 回答者： めぐみん_ 回答日時： 2020/05/12 10:32

上の表の並べ替えだけです。

他の部分は既出なので省略しました。
確実に既出の回答の方がわかりやすいと思いますので、今更～ですかね。
列の増減（Ｅ列以降）については対応してます。

Sub megu()
Dim AL As Object
Dim r As Range, col_count As Integer, i As Integer
Dim v1 As Variant, v2 As Variant, vv As Variant

Set AL = CreateObject("System.Collections.ArrayList")

With Worksheets("Sheet1")
col_count = .Cells(1, Columns.Count).End(xlToLeft).Column - .Range("E1").Column + 1

For Each r In .Range("C1", .Cells(1, "C").End(xlDown))
For Each vv In Split(r.Value, ",")

If vv <> "" Then

If r.Offset(, -1).Value <> "" Then v1 = Array(vv, r.Offset(, -1).Value): _
v2 = r.Offset(, 2).Resize(, col_count).Value
AL.Add (CreateObject("System.Collections.ArrayList"))
With AL(AL.Count - 1)
.Add (v1)
.Add (v2)
End With

End If

Next
Next

End With

With Worksheets("Sheet2")

For i = 0 To AL.Count - 1
With .Cells(i + 1, 1)
.Value = IIf(i = 0, "No", i)
.Offset(, 1).Resize(, 2).Value = AL(i)(0)
.Offset(, 3).Resize(, col_count).Value = AL(i)(1)
End With
Next

End With

Set AL = Nothing

End Sub

この回答へのお礼

お礼が遅くなりすみません。
こう言う事が容易にできるスキル、羨ましい限りです。
ありがとうございます。

お礼日時：2020/05/17 21:02

No.9 回答者： めぐみん_ 回答日時： 2020/05/11 07:54

これって先の質問ではカンマ区切りしていない表があるのですよね？

カンマ区切りで纏めて何をしたのかはわかりませんが、キーワードで元の表を修正（又は全てコピペしてから）でも宜しかったのでは？
この点については双方に回答されている方なら既に疑問を感じておられたかもですけど。

No.8 回答者： めぐみん_ 回答日時： 2020/05/10 17:37

＞④Info1以降の項目については、

とあって一番右の項目名も『Info・・・』となっているのですが、もしかして列数はもっとあるのかなぁ？

この回答へのお礼

はい、項目数については増える可能性もありますが
画像イメージの列数で教えて頂けたら、増えた際は
どうにか修正して対応しようと思っていますので
現画像イメージで問題ございません。
お気遣いありがとうございます。

お礼日時：2020/05/11 17:02

No.6 回答者： めぐみん_ 回答日時： 2020/05/10 09:10

No.5です。

最初に記載されてましたね。ごめんなさい。
スル～してください。

No.5 回答者： めぐみん_ 回答日時： 2020/05/10 08:27

No.1です。

赤枠の範囲は画像に示している通りの固定でしょうか？
それとも行数は変動しますか？

と言うかシート１の表の下２行開けての行から最下行までをコピペでも宜しいのかな？
順番の入れ替え・詰めるは必要でしょうけど。

No.4 回答者： Qchan1962 回答日時： 2020/05/10 04:06

＃３です。

検証の結果
先のものでも動くと思いますが、正しくないので訂正いたします。

誤り：見出し行を範囲に入れている。見出し行番号に+1する。配列要素数に+1している。

修正前
　 　 　 　 nx = .Cells(1, "D").End(xlDown).Row　　’見出し行を探しています
　 　 　 　 n = .Cells(nx, "D").End(xlDown).Row　　’Name2には空白行が無いのでデータの最下位行を取得
　 　 　 　 ds = Application.Sum(.Range("E" & nx & ":E" & n)) + 1　　 '配列0から始まるので-1 タイプミス
修正後
nx = .Cells(1, "D").End(xlDown).Row + 1
n = .Cells(nx, "D").End(xlDown).Row
ds = Application.Sum(.Range("E" & nx & ":E" & n)) - 1

nx変更に伴い
修正前
　 　 　 　 Ws.Range("C" & ds + nx + 4).Resize(3, 1).Value = .Range("D" & n + 3 & ":D" & n + 5).Value
　 　 　 　 Ws.Range("D" & ds + nx + 4).Resize(3, 1).Value = .Range("C" & n + 3 & ":C" & n + 5).Value
　 　 　 　 Ws.Range("E" & ds + nx + 4).Resize(3, 3).Value = .Range("F" & n + 3 & ":H" & n + 5).Value
　 　 End With

　 　 Ws.Range("B4").Resize(ii, 6) = Ans
　 　 Ws.Range("B4").CurrentRegion.Borders.LineStyle = xlContinuous
　 　 Ws.Range("F" & ds + nx + 4).CurrentRegion.Borders.LineStyle = xlContinuous
　 　 Ws.Range("F" & ds + nx + 6).CurrentRegion.Borders.LineStyle = xlContinuous

修正後
Ws.Range("C" & ds + nx + 3).Resize(3, 1).Value = .Range("D" & n + 3 & ":D" & n + 5).Value
Ws.Range("D" & ds + nx + 3).Resize(3, 1).Value = .Range("C" & n + 3 & ":C" & n + 5).Value
Ws.Range("E" & ds + nx + 3).Resize(3, 3).Value = .Range("F" & n + 3 & ":H" & n + 5).Value
End With
Ws.Range("B4").Resize(ii, 6) = Ans
Ws.Range("B4").CurrentRegion.Borders.LineStyle = xlContinuous
Ws.Range("F" & ds + nx + 3).CurrentRegion.Borders.LineStyle = xlContinuous
Ws.Range("F" & ds + nx + 5).CurrentRegion.Borders.LineStyle = xlContinuous


すみません。。

この回答へのお礼

改善版もあるのですね。
教えて頂き助かります。

お礼日時：2020/05/10 22:29

No.3 回答者： Qchan1962 回答日時： 2020/05/10 03:22

Sheet1の項目№がB3セルとして

出力はSheet2のB4セルから出力します。（見出しは触っていません。データのみです）
想定もとデータ表は図を参照してください。変更前のCount項目でデータ数を算出しているので必須
無い場合は、別の方法でカウントする必要があります。
コード内のSheetはシートインデックスにしていますので、書き換えて下さい。
べたに書いていますので適所変更してください。

Sub Sample()
Dim Ws As Worksheet
Dim n As Long, nx As Long, i As Long, j As Long
Dim ii As Long, jj As Long, cnt As Long, ds As Long
Dim Trg As String
Dim tmp As Variant, Ans As Variant
　 　 Set Ws = Sheets(2)
　 　 With Sheets(1)
　 　 　 　 nx = .Cells(1, "D").End(xlDown).Row
　 　 　 　 n = .Cells(nx, "D").End(xlDown).Row
　 　 　 　 ds = Application.Sum(.Range("E" & nx & ":E" & n)) + 1
　 　 　 　 ReDim Ans(ds, 5)
　 　 　 　 cnt = 1
　 　 　 　 For i = nx + 1 To .Cells(nx, "D").End(xlDown).Row
　 　 　 　 　 　 If Right(.Cells(i, "D"), 1) = "," Then
　 　 　 　 　 　 　 　 Trg = Left(.Cells(i, "D"), Len(.Cells(i, "D")) - 1)
　 　 　 　 　 　 Else
　 　 　 　 　 　 　 　 Trg = .Cells(i, "D")
　 　 　 　 　 　 End If
　 　 　 　 　 　 tmp = Split(Trg, ",")
　 　 　 　 　 　 If jj > 0 Then jj = jj + 1
　 　 　 　 　 　 For j = 0 To UBound(tmp)
　 　 　 　 　 　 　 　 If .Cells(i, "C") <> "" Then jj = 0
　 　 　 　 　 　 　 　 If .Cells(i, "C") = "" And jj = 0 Then jj = 1
　 　 　 　 　 　 　 　 Ans(ii, 0) = cnt
　 　 　 　 　 　 　 　 Ans(ii, 1) = tmp(j)
　 　 　 　 　 　 　 　 Ans(ii, 2) = .Cells(i - jj, "C")
　 　 　 　 　 　 　 　 Ans(ii, 3) = .Cells(i - jj, "F")
　 　 　 　 　 　 　 　 Ans(ii, 4) = .Cells(i - jj, "G")
　 　 　 　 　 　 　 　 Ans(ii, 5) = .Cells(i - jj, "H")
　 　 　 　 　 　 　 　 ii = ii + 1
　 　 　 　 　 　 　 　 cnt = cnt + 1
　 　 　 　 　 　 Next
　 　 　 　 Next
　 　 　 　 Ws.Range("C" & ds + nx + 4).Resize(3, 1).Value = .Range("D" & n + 3 & ":D" & n + 5).Value
　 　 　 　 Ws.Range("D" & ds + nx + 4).Resize(3, 1).Value = .Range("C" & n + 3 & ":C" & n + 5).Value
　 　 　 　 Ws.Range("E" & ds + nx + 4).Resize(3, 3).Value = .Range("F" & n + 3 & ":H" & n + 5).Value
　 　 End With

　 　 Ws.Range("B4").Resize(ii, 6) = Ans
　 　 Ws.Range("B4").CurrentRegion.Borders.LineStyle = xlContinuous
　 　 Ws.Range("F" & ds + nx + 4).CurrentRegion.Borders.LineStyle = xlContinuous
　 　 Ws.Range("F" & ds + nx + 6).CurrentRegion.Borders.LineStyle = xlContinuous
　 　
End Sub

この回答へのお礼

ご教授、ありがとうございます。
大変助かります。

お礼日時：2020/05/10 22:28

No.2 回答者： tom04 回答日時： 2020/05/10 00:05

こんばんは！

https://oshiete.goo.ne.jp/qa/11618810.html
　　↑のサイトの質問の逆をやりたい！というコトですかね。

一例です。
標準モジュールにしてください。

Sub Sample2()
　Dim i As Long, k As Long
　Dim lastRow As Long
　Dim wS As Worksheet
　Dim myStr As String, buf As String
　Dim myAry1, myAry2

　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　'//▼Sheet2の2行目以降データを一旦消去//
　　　　lastRow = .UsedRange.Rows.Count
　　　　　If lastRow > 1 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "F")).Clear
　　　　　End If

　　　　'//▼ココから操作//
　　　　i = 2
　　　　　Do While wS.Cells(i, "C") <> ""
　　　　　　If wS.Cells(i, "B") <> "" Then
　　　　　　　myStr = wS.Cells(i, "B")
　　　　　　　buf = wS.Cells(i, "E") & "_" & wS.Cells(i, "F") & "_" & wS.Cells(i, "G")
　　　　　　End If
　　　　　　　myAry1 = Split(wS.Cells(i, "C"), ",")
　　　　　　　myAry2 = Split(buf, "_")
　　　　　　　　For k = 0 To UBound(myAry1)
　　　　　　　　　With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　　　　　.Value = .Row - 1
　　　　　　　　　　.Offset(, 1) = myAry1(k)
　　　　　　　　　　.Offset(, 2) = myStr
　　　　　　　　　　.Offset(, 3) = myAry2(0)
　　　　　　　　　　.Offset(, 4) = myAry2(1)
　　　　　　　　　　.Offset(, 5) = myAry2(2)
　　　　　　　　　End With
　　　　　　　　Next k
　　　　　　i = i + 1
　　　　　Loop
　　　　.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
　　　　wS.Cells(i + 2, "A").Resize(3, 3).Copy .Cells(Rows.Count, "A").End(xlUp).Offset(3)
　　　　wS.Cells(i + 2, "E").Resize(3, 3).Copy .Cells(Rows.Count, "D").End(xlUp).Offset(3)
　　　　.Activate
　　　End With
　　　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

はい、前回の質問の逆仕様になります。
またご教授、ありがとうございます。

お礼日時：2020/05/10 22:30

No.1 回答者： めぐみん_ 回答日時： 2020/05/09 22:19

＞⑥sheet1のカンマ区切りで、行最後にカンマが無い場合もあります。

(赤線部)

画像を拡大すると老眼のせいなのかカンマはあるけどデータが無いように見えますが、カンマが本当に無いならこの情報は不要なもののようにも思えますけど？

あと赤枠で囲った部分はシート１では先に存在している物なのですよね？
要は行の一番下から上に向かって最終行を求める事は厳しいとみてよいですか？

またName1のNo1が空白になる事はありませんか？

この回答へのお礼

あと赤枠で囲った部分はシート１では先に存在している物なのですよね？

回答）　はい、その通りです。


要は行の一番下から上に向かって最終行を求める事は厳しいとみてよいですか？
回答）　はい、その通りです。


またName1のNo1が空白になる事はありませんか？
回答）　No1での空白は無いです。

お礼日時：2020/05/10 22:27