VBA　エクセル2010　横長データを縦にまとめる（複数グループを一つのグループにする）

Question

初心者で勉強中なので、まだまだVBAを使い慣れていません。急ぎの業務で実力以上の内容に手をつけざるを得ず、困っております。どなたかお知恵拝借できますでしょうか。よろしくお願いいたします。データについては画像でお分かりいただけますでしょうか。＊写真では項目は「ID02」まで、下記の例とは内容は異なります現在の形 sheet1 （項目名） № 項目１～項目１０　ID01　大分類中分類　小分類～　ID20　大分類中分類　小分類希望の形 sheet1からsheet2に転記 № 項目１～項目１０　ID01　大分類中分類　小分類 № 項目１～項目１０　ID02　大分類中分類　小分類 № 項目１～項目１０　ID05　大分類中分類　小分類 № 項目１～項目１０　ID20　大分類中分類　小分類 ①A列「№」～k列「項目10」に対して、入力のあるL列以降の複数グループ「ID01」～「ID20」（それぞれ4列が一つのグループ）を一つのグループとしてまとめて転記したいです。やりたいことは下記です。 ①見出し行（指定の行）以下から処理を開始する ②「ID01」に入力がない場合でも、「№」～「項目10」まで入力があれば転記 ③「ID01」～「ID20」で入力がない「ID**」は転記しないが、入力のある・なしは不規則入力のないものだけ転記をスキップする　　 VBAは書きかけですが、下記の回答を参考にしてみました。 R2の設定あたりから躓いています。なお、項目数やIDの詳細数が変わる可能性があるので、その際気を付ける変更場所についても合わせて教えていただけますでしょうか。【参考回答】「エクセル2003　横のデータを縦に並べたいです。」 http://oshiete.goo.ne.jp/qa/5605894.html?from=navi_recommend ------------------------- Sub 転記() Dim I As Long, X As Long Dim R1 As String, R2 As String I = 1: X = 1 Application.ScreenUpdating = False Do While Range("Sheet1!A" & I).Value <> "" 'Sheet1の行移動ループ R1 = "": R2 = "L" Do While Range("Sheet1!" & R1 & R2 & I).Value <> "" 'Sheet1の列移動ループ Range("Sheet2!A" & X).Value = Range("Sheet1!A" & I).Value Range("Sheet2!B" & X).Value = Range("Sheet1!B" & I).Value Range("Sheet2!C" & X).Value = Range("Sheet1!C" & I).Value Range("Sheet2!D" & X).Value = Range("Sheet1!D" & I).Value Range("Sheet2!E" & X).Value = Range("Sheet1!E" & I).Value Range("Sheet2!F" & X).Value = Range("Sheet1!F" & I).Value Range("Sheet2!G" & X).Value = Range("Sheet1!G" & I).Value Range("Sheet2!H" & X).Value = Range("Sheet1!H" & I).Value Range("Sheet2!I" & X).Value = Range("Sheet1!I" & I).Value Range("Sheet2!J" & X).Value = Range("Sheet1!J" & I).Value Range("Sheet2!K" & X).Value = Range("Sheet1!K" & I).Value Range("Sheet2!L" & X).Value = Range("Sheet1!" & R1 & R2 & I).Value If R2 = "Z" Then '列移動コード If R1 <> "" Then R1 = Chr(Asc(R1) + 1) Else R1 = "A" End If Else R2 = Chr(Asc(R2) + 1) End If X = X + 1 'Sheet2の次の行へ Loop I = I + 1 'Sheet1の次の行へ Loop Application.ScreenUpdating = True MsgBox ("完了") End Sub どうぞよろしくお願いいたします。

soixante · Accepted Answer

補足を拝見しました。そうですね、IDが一個もなくても、頭の部分の転記はせねばならないんですね。以下でどうでしょう。IDの有無を判別するIf文を追記して若干アレンジしました。私の手元のダミーデータでは正常稼働しました。これで行けてるかなあ？なにかありましたらまたどうぞ。 '--------------------------------------------------------------------- Option Explicit Sub Tenki3() '変数宣言とセット Dim Ws1 As Worksheet, Ws2 As Worksheet Dim r As Long, c As Long Dim Heada As Range, Rng As Range, Cnt As Integer Dim TgtRow As Long Set Ws1 = Worksheets(1) Set Ws2 = Worksheets(2) '前回結果（Sheet2）をクリア Ws2.Select Set Rng = Ws2.Cells(1, 1).CurrentRegion If Rng.Rows.Count > 1 Then 'まだクリアされてないなら　Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count) 'Sheet2の見出し行を除く範囲をRngにセット　Rng.ClearContents End If Application.ScreenUpdating = False 'Sheet1を縦にループ r = 2 With Ws1 　Do While .Cells(r, 1).Value <> "" 　　Set Heada = .Range(.Cells(r, 1), .Cells(r, 11)) 'ヘッダ（A～K列）をHeadaに格納　　Cnt = Application.WorksheetFunction.CountA(.Range(.Cells(r, 12), .Cells(r, 91))) '当該行L～CM列、空白でないセルの個数　　If Cnt = 0 Then 'ひとつもIDが入ってないなら　　　　TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 　　　　Heada.Copy Ws2.Cells(TgtRow, 1) 'ヘッダをSheet2の最終行にコピペ　　ElseIf Cnt > 0 Then '一つ以上IDがあるなら　　　　For c = 12 To 88 Step 4 'L～CJ列を4つおきにループ　　　　　　If .Cells(r, c).Value <> "" Then 'IDがあるなら　　　　　　　　TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 　　　　　　　　Heada.Copy Ws2.Cells(TgtRow, 1) 'ヘッダをSheet2最終行A列にコピペし、　　　　　　　　Set Rng = .Range(.Cells(r, c), .Cells(r, c + 3)) 　　　　　　　　Rng.Copy Ws2.Cells(TgtRow, 12) '大中小分類をSheet2最終行L列にコピペ　　　　　　End If 　　　　Next c 　　End If 　　r = r + 1 　Loop End With Application.ScreenUpdating = True MsgBox "Completed." End Sub ’----------------------------------------------------------------- それぞれのステートメントにコメントを振りましたので、お分かり頂けると思いますが、メンテの際について。＞項目数やIDの詳細数が変わる可能性があるので、その際気を付ける変更場所・項目数　上のコード内では「ヘッダ」と呼んでいる箇所。A～K列の部分をいじってください。　変数Heada のところとか。　それに伴い、Sheet2のL列からデータを貼っていますので、そこに該当する部分も。・IDの詳細数　L～CJ列のループを入れているところとか、変数Rngに格納する部分をいじる必要が出てきます。上記のようにコードの修正をするときや、エラーが出た時、想定外の挙動を見せた時など、一段階ずつコードを実行させながら動きを確認していくことも有効です。ステップ実行と呼ばれるものですが、コード内にカーソルを置き、F8キーを押していくと、一段階ずつ進んでいきます。あわせて、VBE画面の「表示(V)」＞「ローカルウィンドウ(S)」も表示させて、併用すると、各変数がどのような動きをしているかも見られます。 ------------------------------------------------------------------- 行列両方向のループについてこのように縦横両方向へのループはかなり高い頻度で使用されます。今回の例でいえば、Sheet1の元データを2行目から下方向へ見ていく。んでもって、各行において、ID1～ID20まで右方向へ見ていく。ループ回数が決まっているとすれば、縦横ループは以下の形がまずは基本。例） Dim r As Integer,c As Integer For r=1 to 10 　For c=1 to 10 　　Cells(r,c).Value=r*c 　Next c Next r 今回は縦方向のデータ数が不定なので、縦のループは、Do Loopを使いました。このように、縦方向のデータ数不定、でも、右方向の項目数は固定、というのは最も多いパターンです。したがって、Do Loop と、For Next との使い分けも意識してみてください。また、それぞれのループを内側に置くか、外側に置くかで結果が変わることもありますのでいろいろ研究してみましょう。 ※なお、縦（下）方向のカウンタは行（Row)という意味で r 、列（右）方向のカウンタは列（Column)という意味で c と置くのが、わたしは好きですが、決まりではありませんので誤解なさらぬよう。

soixante · Answer

たびたびすみません。ちょっと図がはっきり見えないので判断しきれませんが、
IDは、Sheet1の時点で、もう　0001－001 のようになってる？　んですかね。
だったら、＃１のコードで良いかと思います。

Tenki と　Tenki2　両方を回してみてください。

soixante · Answer

#1です。申し訳ありません。こちらのコードにしてください。 Sheet2のL列（ID）のところ、No.とID番号を連結させたデータであることを失念していました。 '----------------------------------------------------------------------- Option Explicit Sub Tenki2() '変数宣言とセット Dim Ws1 As Worksheet, Ws2 As Worksheet Dim r As Long, c As Long, k As Integer Dim Heada As Range, Rng As Range Dim TgtRow As Long, id As String Set Ws1 = Worksheets(1) Set Ws2 = Worksheets(2) Application.ScreenUpdating = False '前回結果（Sheet2）をクリア Set Rng = Ws2.Cells(1, 1).CurrentRegion Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count) Rng.ClearContents 'Sheet1を縦にループ r = 2 With Ws1 　　Do While .Cells(r, 1).Value <> "" 　　Set Heada = .Range(.Cells(r, 1), .Cells(r, 11)) 'A～K列の値をHeadaに格納　For c = 12 To 88 Step 4 'L～CJ列まで4つおきにループ　　　If .Cells(r, c).Value <> "" Then 'IDが記載されているなら　　　Set Rng = .Range(.Cells(r, c + 1), .Cells(r, c + 3)) '大中小分類3列1セットをRngに格納　　　k = (c - 8) / 4 'ID何番かを計算　　　id = .Cells(r, 1).Value & "-" & Format(k, "0000") 'Sheet2に書く、No+ID を生成　　　TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Sheet2の転記すべき行を取得　　　Rng.Copy Ws2.Cells(TgtRow, 13) 'Rng をSheet2のM列にコピペ　　　Ws2.Cells(TgtRow, 12).Value = id 'id をSheet2のL列にコピペ　　　Heada.Copy Ws2.Cells(TgtRow, 1) 'HeadaをSheet2のA列にコピペ　　　End If 　　Next c 　　r = r + 1 　Loop End With Ws2.Select Application.ScreenUpdating = True MsgBox "Compeled." End Sub '----------------------------------------------------------------------- ちょっとやってみてください。何かありましたらどうぞ。

soixante · Answer

こんな形でやってみました。

’------------------------------------------------------------
Option Explicit

Sub Tenki()

'変数宣言とセット
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim r As Long, c As Long
Dim Heada As Range, Rng As Range
Dim TgtRow As Long

Set Ws1 = Worksheets(1)
Set Ws2 = Worksheets(2)

'Sheet1を縦にループ
r = 2
With Ws1
Do While .Cells(r, 1).Value <> ""
Set Heada = .Range(.Cells(r, 1), .Cells(r, 11)) 'A～K列の値をHeadaに格納

For c = 12 To 88 Step 4 'L～CJ列まで4つおきにループ
If .Cells(r, c).Value <> "" Then 'IDが記載されているなら
Set Rng = .Range(.Cells(r, c), .Cells(r, c + 3)) '4列1セットのデータをRngに格納
TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Sheet2の転記すべき行を取得
Rng.Copy Ws2.Cells(TgtRow, 12) 'Rng をSheet2のL列にコピペ

Heada.Copy Ws2.Cells(TgtRow, 1) 'HeadaをSheet2のA列にコピペ
End If
Next c

r = r + 1
Loop
End With

MsgBox "Compeled."

End Sub
’------------------------------------------------------------

以下余談です。よろしければ今後の参考としてください。

ID1からID20まで見に行く、つまり、ずらっと右へ確認しに行くわけですから、
ループを使わないと無理があります。
その時に、Range(1,"A")　みたいな書式では限界があります。
いちいち、"A",”B",なんて書き換えていくわけには行きませんから。
実際のところ、あなたが書いたコードの、「'Sheet1の列移動ループ」の部分というのも、
同じ内容を、A~Kまで11回書いています。
これではVBAを使っている意味があまり感じられません。
これから学習されるのだと思いますが、ループを上手に使ってください。

また、ループをするには、Cells(r,c)　の書式で書く方法を学んだほうが後々ラクですよ。
Range("A1")、Range(1,"A") 等の書き方では、行番をループするには数字ですからいいですが、
列番（アルファベットの部分）をループするには無理があります。
列番の部分も数値で回していけるのがCellsです。
Cells(行番、列番）です。
A1セルなら、Cells(1,1)、 E1セルなら　Cells(1,5) 、A10セルなら、Cells(10,1) です。

場面場面に応じて、Range、Cells　の使い分けを出来るようにしておくと良いでしょう。

上記のコードの内容において、ご意向にそぐってない点や、ご不明点あればお気軽にお知らせください。

VBA エクセル2010 横長データを縦にまとめる（複数グループを一つのグループにする）

補足を拝見しました。

たびたびすみません。

#1です。

こんな形でやってみました。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

VBA　エクセル2010　横長データを縦にまとめる（複数グループを一つのグループにする）