『空欄だらけのデータ範囲取得→成形』（tata） 再びお世話になります。 以下のような家計簿を、(列数は不明) A B C D E F G 1 日付 食費 金額 交通費 金額 おやつ 金額 2行目は=sumによる合計欄 3 3/9 鶏肉 128 電車代 4,012 チョコ 108 4 レタス 240 5 6 3/10 ネギ 128 プリン 108 7 牛肉 240 ※2017/03/09 13:00 補足　日ごとに空白行があるとは限らない 　8行目に3/11が入っているかも。 　また、同じ日付が複数有る可能性も。 　(レシートごとに記述してある可能性) 以下のように並べ替えたい(VBAの都合で別の並びになっても可) 日付 分類 品名 金額 3/9 食費 鶏肉 128 3/9 食費 レタス 240 3/9 交通費 電車代 4,012 3/9 おやつ チョコ 108 3/10 食費 ネギ 128 3/10 食費 牛肉 240 3/10 おやつ プリン 108 [[20170215141915]] 『縦：項目　横：月度　の表から、データベース様式』 で教えて頂いた知識を応用して作ってみようと考えたのですが、 空白行、5行目があると3行目までしか範囲選択されない？のでしょうか？ また、A4、A7に日付が入っていないことが障害となっている気がします。 For A In B 〜 Next　の構文も、よくわかっていないので勉強中です。 話が散漫な方向に行っていますが、お尋ねしたいのは 上記のような整形を行いたい時、 １・スマートにVBAで出来るやり方がある のか、 ２・元データの形が悪いため、VBAで形を整えた後、整形する方が簡単 なのか。 ３・どういう方針で「プログラミングを考えて」いけば良いのか (まず空白行をこういう方法で探して→削除して→日付をこういう方法で埋めて…？といった感じで考え、構文・書き方を調べる？) ４・できれば完成コード例とその解説を知りたい 以上、よろしくお願いします。 ＜ 使用 Excel：Excel2010、使用 OS：Windows10 ＞ ---- >空白行、5行目があると3行目までしか範囲選択されない？のでしょうか？ そうですね。mmさんのコードでの領域取得は CurrentRegion をベースにしています。 CurrentRegion は、【上下、左右、斜め上下】に値が連続して存在する【連続領域】ですから 空白行や空白列があれば、そこで終わります。 どういったコードで領域を取得すべきかは、そのシートのレイアウトがどのようになっているかで それぞれ、適切なものを使う必要があります。こう書けば万能　という書き方はありません。 このシートを表示して以下のコードを実行してください。 1 が CurrentRegion、2 と 3 が UsedRange というものを使っています。 たまたま、この表は A1 から始まっているので、2 も 3 も　同じ領域になります。 Sub Test() MsgBox Range("A1").CurrentRegion.Address '1 MsgBox Range("A1", ActiveSheet.UsedRange).Address '2 MsgBox ActiveSheet.UsedRange.Address '3 End Sub ただ、UsedRange のほうは、値がなくても数式が入っているセルや、罫線や背景色塗りつぶしのセルも 対象になりますから、ケースバイケースで考えていく必要があります。 >元データの形が悪いため、VBAで形を整えた後、整形する方が簡単なのか。 整えることができれば、それが最も簡単でしょう。 あるいは、ループで処理する際に、A列に値があれば、それを記憶しておいて、日付は、その記憶しておいた値を 用いる という方法も、もちろん可能ですね。 （β） 2017/03/09(木) 08:18 ---- こんにちは Sub test() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim r As Range Dim t As Range Dim i As Long Application.ScreenUpdating = False Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") Sh2.UsedRange.ClearContents Sh2.Range("A1:D1").Value = Array("日付", "分類", "品名", "金額") i = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1 Set t = Sh1.UsedRange.SpecialCells(xlCellTypeConstants) For Each r In t If r.Row > 2 And r.Column > 1 And (r.Column Mod 2 = 0) Then If IsDate(r.EntireRow.Cells(1, 1)) = True Then Sh2.Cells(i, 1) = _ r.EntireRow.Cells(1, 1).Text Else Sh2.Cells(i, 1) = _ r.EntireRow.Cells(1, 1).End(xlUp).Text End If Sh2.Cells(i, 2) = r.EntireColumn.Cells(1, 1) Sh2.Cells(i, 3) = r.Value Sh2.Cells(i, 4) = r.Offset(, 1).Value i = i + 1 End If Next Application.ScreenUpdating = True End Sub こんな感じでもどうでしょう？ （ウッシ） 2017/03/09(木) 08:50 ---- 前トピの mm さんのコードの構えを継承すると、たとえば以下のようなコードが考えられます。 元シートを "Sheet1" 、転記シートを "Sheet2" にしています。 転記シートのタイトル行は、あらかじめ記入しておいてください。 なお、データ領域内の品名は、すべて文字列（数値ではない）という条件です。 また、並び順は、かならずしも左から右ということではなくなりますが。 Sub Sample() Dim pos As Range Dim c As Range Dim d As Date With Sheets("Sheet2") .UsedRange.Offset(1).ClearContents Set pos = .Range("A2") '転記開始行 End With For Each c In Sheets("Sheet1").UsedRange.Offset(2, 1).SpecialCells(xlCellTypeConstants, xlTextValues) If c.EntireRow.Cells(1).Value <> "" Then d = c.EntireRow.Cells(1).Value pos.Value = d pos.Offset(, 1).Value = c.EntireColumn.Cells(1).Value pos.Offset(, 2).Resize(, 2).Value = c.Resize(, 2).Value Set pos = pos.Offset(1) Next End Sub （β） 2017/03/09(木) 09:33 ---- もし、左から右へ、上から下への順番通りに転記するなら Sub Sample2() Dim pos As Range Dim r As Range Dim j As Long Dim d As Date With Sheets("Sheet2") .UsedRange.Offset(1).ClearContents Set pos = .Range("A2") '転記開始行 End With With Sheets("Sheet1").UsedRange With .Offset(2, 1).Resize(.Rows.Count - 2, .Columns.Count - 1) For Each r In .Rows For j = 1 To r.Columns.Count Step 2 If r.Cells(j).Value <> "" Then If r.EntireRow.Cells(1).Value <> "" Then d = r.EntireRow.Cells(1).Value pos.Value = d pos.Offset(, 1).Value = r.Cells(j).EntireColumn.Cells(1).Value pos.Offset(, 2).Resize(, 2).Value = r.Cells(j).Resize(, 2).Value Set pos = pos.Offset(1) End If Next Next End With End With pos.Parent.Select End Sub （β） 2017/03/09(木) 09:50 ---- Sub main() Dim c As Range Sheets("Sheet2").Cells.Clear With Sheets("Sheet1") For Each c In .UsedRange.Offset(2, 1).SpecialCells(xlCellTypeConstants) If c.Column Mod 2 = 0 Then Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = _ Array(IIf(.Range("A" & c.Row).Value = "", .Range("A" & c.Row).End(xlUp).Value, .Range("A" & c.Row).Value), .Cells(1, c.Column).Value, c.Value, c.Offset(, 1).Value) End If Next c End With Sheets("Sheet2").Range("A1").Resize(, 4).Value = Array("日付", "分類", "品名", "金額") End Sub （mm） 2017/03/09(木) 10:57 ---- ＞２・元データの形が悪いため、VBAで形を整えた後、整形する方が簡単 ＞なのか。 ＞３・どういう方針で「プログラミングを考えて」いけば良いのか 遅ればせながら、考え方だけ。 主目的はエクセルで集計しやすい形に整形することなので、 簡単も難しいもないと思います。出来るようにやりましょう＾＾ データベースにするなら計算で求められるものは含めない。 ので、2行目をクリアする。 そうすると1日毎のデータのかたまりが空白行で区切られる。 そうしたら、A列のデータがあるセルをジャンプ機能で取得し、 それぞれを巡回して、 それを含むアクティブな表（空白で区切られたセル範囲）を取得。 それを、列を巡回し、1行1件のデータに変換していく の繰り返し で、いかがでしょう。 （まっつわん） 2017/03/09(木) 11:49 ---- 皆様ありがとうございます。 夜にじっくり見させていただきます。 私の最初の提示が不十分だったと思うので、 ごめんなさい、補足入れます。 日ごとに、空白行が「入っているとは限らない」状態です。 まっつわんさんの考え方の、 「必ず日ごとに空白行が入るルールで記述されているならば」 >1日毎のデータのかたまりが空白行で区切られる。 というのは思いつきませんでした。 空白は憎き敵、みたいな考えだったのですが、 それを区切り位置として利用、という考え方の転換は眼から鱗です。 取り急ぎ皆様への感謝と補足説明まで。 （tata） 2017/03/09(木) 12:59 ---- ＞日ごとに、空白行が「入っているとは限らない」状態です。 別にそうでなくても、いいのですが。 俯瞰してみて、 どのようなルール（規則）があるのか考える。 じゃ、そのルールを手動の操作で表現したらどうなるか。 その手順を自動化すればよいだけの話です。 その手順をVBA語に翻訳すれば、 エクセル君がその手順で自動で仕事をしてくれるだけです。 （まっつわん） 2017/03/09(木) 13:11 ---- >２・元データの形が悪いため、VBAで形を整えた後、整形する方が簡単 なのか。 コメントしましたが、このほうが自分でやりやすければ、これも立派な方法です。 たとえば A列の日付が空白なので面倒だということなら以下のように そこを日付で埋める ---> 処理をする ---> 空白に戻す　という方法もあります。 Sub Test() Dim r As Range With ActiveSheet.UsedRange Set r = .Columns("A").SpecialCells(xlCellTypeBlanks) r.FormulaR1C1 = "=R[-1]C" MsgBox "いかがですか" 'ここで表領域の処理 r.ClearContents End With End Sub （β） 2017/03/09(木) 15:15 ---- ・報告、お礼 βさん ウッシさん mmさん いずれのコードも期待したとおりの動作を致しました。 コードの意図等、これから勉強させていただきます。 ありがとうございます。 まっつわんさん 考え方御指南ありがとうございます。 ・考え方の添削 自分の知識と発想で手順化すると、 [[20170215141915]] のように、 最終行、最終列を取得しておく '皆さんご教示のUsedRangeが活用できる？ '質問前はRange("A1").SpecialCells(xlLastCell)みたいなのが使えるかと考えていた A3から A3をコピー→シート2にペースト A3を変数に記録しておき、次行以降の処理の時、A列空白なら変数の値を用いる 'βさんご教示法 B列目から B3:C2をコピー→シート2にペースト B1をコピー→シート2にペースト 書き出し行を1行下へ 2列右へ移動して最終列まで繰り返し 次の行に移動して最終行まで繰り返し といった力技になるかと思います。 まず、コピー→ペースト　よりも、皆さんの書かれているような 転記先.value = 転記元.value の方が良いんですよね？ 他にも、私の考え方の、「まずいところ」を指摘していただければと思います。 ・この後 皆様のコード、構文と意味調べながら咀嚼したいと思います。 コードの意図等、わからない場合、質問させていただくかと思いますが、よろしくお願いします。 （tata） 2017/03/09(木) 18:59 ---- 咀嚼1 CurrentRegionプロパティでは空白のセルで囲まれた範囲を読み取り、参照する Range("A1").CurrentRegion.Address では、A1を含む連続領域が指定される UsedRangeプロパティは指定されたワークシートで使われたセル範囲 "使われたセル"は、書式変更等も含む この時、空白行と空白列が頭にあり、"使われたセル範囲"が例えばC3:G10とかだった場合、 Range("A1", ActiveSheet.UsedRange).Address と ActiveSheet.UsedRange.Address では違う結果が返る。 上記例では$A$1:$G$10 と、 $C$3:$G$10 （tata） 2017/03/09(木) 19:25 ---- 咀嚼2 i = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1 iに、Sheet2のA列最終行 + 1 を代入 Rows.Count は、シートの最終行。65535とか1048576 Endは、Rangeオブジェクトのプロパティで、Rangeオブジェクトを返す。[Ctrl] + [方向キー]と同様。xlUpは上へ。 これで返ってくるのは、Rangeなので、.Rowプロパティで 行数 をもらう。 Set t = Sh1.UsedRange.SpecialCells(xlCellTypeConstants) tに、データの入っている範囲、Rangeオブジェクトをセット .SpecitalCellsメソッドはある特定の条件に該当するセルをまとめて抽出 xlCellTypeConstantsは定数が含まれているセル この場合だと2行目の=sumは選ばれず、 A1:G1:,A3:G3,B4:C4…と、空白じゃない数字が入っている範囲がtにセットされる For Each〜Nextステートメントは、コレクションや配列に対して、同じ処理を繰り返す For Each r In t Next それぞれの 変数r(range型) に対し コレクション・オブジェクトを代入？ ええと、 r に、 tを順に代入し、一つ一つのtの中身ごとに、nextまでの処理を繰り返す？という構文で間違ってないですか？ tという配列の中身は(A1,A2,A3,A4…B7,C7)というRangeの集まりで、 1回めの処理ではrの中身はA1, 2回めの処理ではrの中身はA2…という仕組みでしょうか？ （tata） 2017/03/09(木) 21:20 ---- ＞r に、 tを順に代入し、一つ一つのtの中身ごとに、nextまでの処理を繰り返す？ ＞という構文で間違ってないですか？ For Each...Next ステートメント 配列やコレクションの各要素に対して、一連のステートメントを繰り返し実行する フロー制御ステートメントです。 つまりRangeオブジェクト（＝セル範囲）は、セルの集合体（＝コレクション）です。 その集合体を構成する各要素（個々のセル）を巡回して、 ステートメント（＝命令文）を繰り返します。 （まっつわん） 2017/03/09(木) 21:37 ---- Cells Worksheets Workbooks よく考えるとみんな複数形。 コレクション（集まり）を表現してるんですよね＾＾ （まっつわん） 2017/03/09(木) 21:45 ---- For Each r In t If r.Row > 2 And r.Column > 1 And (r.Column Mod 2 = 0) Then If IsDate(r.EntireRow.Cells(1, 1)) = True Then Sh2.Cells(i, 1) = _ r.EntireRow.Cells(1, 1).Text 各要素(個々のセル)について 2行より下(3行目以降)かつ 1列より右(B列以降)かつ 列数偶数(B,D,F…)なら r.EntireRow.Cells(1, 1)　個々のセル位置の行全体を取得し、その行全体の(1,1)個め、つまりA列が IsDate() 日付データ　なら、 Sheet2の末尾行(i行)の1列(A列)に rの行全体の(1,1)位置、つまり日付を入力する '.Textは文字列型　.Valueはバリアント型　→　日付がシリアル値なら、.valueの方が良い？ （tata） 2017/03/09(木) 23:29 ---- こんにちは '.Textは文字列型　.Valueはバリアント型　→　日付がシリアル値なら、.valueの方が良い？ 掲載されたデータ例をコピペしたものではTextの方が書式変換せずに済んだので。 そこは実情に合わせて適宜変更して下さい。 'つまりA列が IsDate() 日付データ でなかった場合は、 r.EntireRow.Cells(1, 1).End(xlUp).Text そのA列のセルから上のデータの有るセルを探してその値をセットしてます。 （ウッシ） 2017/03/10(金) 07:54 ---- ＞'.Textは文字列型　.Valueはバリアント型　→　日付がシリアル値なら、.valueの方が良い？ シリアル値を取得するならValue2プロパティを使ってください。 https://www.moug.net/tech/exvba/0050148.html Textプロパティは表示されている文字列を取得します。 （まっつわん） 2017/03/10(金) 11:09 ---- 咀嚼 【1】 .Offset(, 1) 指定されている要素、Range,範囲、セル位置を○行、×列ずらす(0,1)は(,1)のように省略可 .Resize(, 5) 指定されている範囲を( )内の大きさに変更する。 Range("A1:C3").Resize(,5)　なら、 A1:C5範囲を指定していることになる 【2】 Set r = .Columns("A").SpecialCells(xlCellTypeBlanks) r.FormulaR1C1 = "=R[-1]C" A列の空白行を選択、-1行上を相対参照 【3】 　mmさんの Array(IIf(.Range("A" & c.Row).Value = "", .Range("A" & c.Row).End(xlUp).Value, .Range("A" & c.Row).Value), .Cells(1, c.Column).Value, c.Value, c.Offset(, 1).Value) IIf関数 IIf(.Range("A" & c.Row).Value = "", .Range("A" & c.Row).End(xlUp).Value, .Range("A" & c.Row).Value これは意味としては If Range("A" & c.Row).Value = "" Then .Range("A" & c.Row).End(xlUp).Value Else .Range("A" & c.Row).Value End If みたいな意味で良いんですよね。 Array 配列の左端に日付を入れるために、IIf関数を使用している、と。 【謝意】 βさん、ウッシさん、mmさん、まっつわん さん 問題解決後の、「勉強」にも多くの時間おつきあい頂き、ありがとうございました。 For Each...Next ステートメントの考え方、 コレクションの各要素について処理が可能、ということは、 全てのグラフのなんとかをどうにかする、みたいなこともできそうで、 面白かったです。 勉強になりました。 （tata） 2017/03/11(土) 20:17