• 締切済み

Excel VBA で集計合計を高速化するには

処理速度の高速化についてご助言をお願いします。 12枚(月毎)のシートに  約700行と10列の表 (期間、担当者、納入先(D)、商品(E)、売上数量(F)、売上単価(G)、売上金額(H)、売上原価(I)、粗利益額(J)) ⇒上のアルファベットは、列名 納入先名D毎と商品名E毎を基準に検索し、同種のものがあれば、F~Jまでをそれぞれ加算していく。 私のコードは、 1、まず初めに12ヶ月のデータを作成済みのシート「集計」へコピーする。 '----------納入先名、商品名の列判定----------- Select Case Range("AC1").Value  ’納入先名、商品名どちらで処理するかを選択 Case 4 CoN = "D": C = 30       ’”D"は元データの納入先の列と30は合計を入力する列数 Case 5 CoN = "E": C = 31       ’”D"は元データの商品名の列と31は合計を入力する列数 End Select LaRow = Worksheets("集計").Cells(Rows.Count, C).End(xlUp).Row Worksheets("集計").Range("AN2:AS" & LaRow + 1).ClearContents '----------集計----------- ' For Sn = 1 To 12   ’各月のデータをシート「集計」へコピー SnLaRow = Worksheets(Sn).Range(CoN & Rows.Count).End(xlUp).Row Pst = Worksheets(Sn).Range("A2:" & "J" & SnLaRow) LaRow = Worksheets("集計").Range(CoN & Rows.Count).End(xlUp).Row LaRow = LaRow + 1 Worksheets("集計").Range("A" & LaRow & ":" & "J" & LaRow + SnLaRow - 1) = Pst Next Sn これも遅いときは、約3秒かかります。 2、コピーしたデータを下に納入先(約400)、商品名(約500)を検索しながら計を求める。 SnLaRow = Worksheets("集計").Range("A" & Rows.Count).End(xlUp).Row  ’コピー後のデータの最終行 LaRow = Worksheets("集計").Cells(Rows.Count, C).End(xlUp).Row For NS = 3 To LaRow   ’ LaRowは、納入先または商品名の最終行 With Worksheets("集計") For K = 6 To 10   合計したデータはSumIf関数によってAN~ASの列に .Cells(NS, K + 35).Value = Application.WorksheetFunction.SumIf(.Range(Cells(2, CoN), Cells(SnLaRow, CoN)), Cells(NS, C).Value, (.Range(Cells(2, K), Cells(SnLaRow, K)))) Next End With Next NS こちらの速さは、約4秒かかります。 よろしくお願いします。

みんなの回答

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

>全コード・サンプルを投稿しようとしますと字数が不足し、コードの一部分しか投稿できませんでした。 最近ですが、よそのダウンロードサイトなどを借りて、ワークブックをアップロードする人が出てきましたね。ここの規約が内部でどういう変わったのか分かりませんが、1年ぐらい前は、削除されていたのですが、今は、削除されていません。回答者はしていないのですが、質問者さんはやっているようです。 もし、ここにコードを出す場合は、半角スペースがネックになるようです。半角スペースを1文字と数えるので、すぐに一杯になるようです。 それはとかもく、OSとExcelのバージョンはいくつですか?

wellfield
質問者

補足

お返事ありがとうございます。 OSは、XPがコード作成には主ですが、操作には、VistaもWin7もあります。 また、Excelについても作成は、2003ですが、同じく操作には2007も2010もあります。

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.2

>体感的にもう少しせめて0.5秒以内とかには、むりなのでしょうか? こういうのは、物理的・スペック的な問題にも含まれます。私としては、もうこういう掲示板の質問には不向きかもしれないなって思います。10分以上掛かるものを、もう少し早くしてほしいという話なら、相談には乗れるけれども、数秒の問題を1秒以内にしてほしいという要求は、難題の部類に入ります。ただ、そういう問題を好きな人たちもいますから、本来、コードを全部と、どんなデータかサンプルがでていれば、掲示板で相談に乗る人も出てきます。今回は、直接の指摘は無理です。 「高速化」として、Office Tanaka の田中亨氏のようなナンセンスなコードを出して、コンマ何秒速いとか、自分のサイトで出していますが、そういうのは、ベテランの人には顰蹙ものだと思います。 また、高速化という言葉は、Microsoft VBAにはありませんが、「最適化」という言葉があります。 VBAは、スクリプト型とコンパイル型の両方の要素を持っていますから、その特徴を良く理解して使うことです。 後は、ご自身で考えてほしいですが、以下は、100%を守る必要がないけれども、経験的に、一般論として、こういう処理方法があります。 最適化テクニック 1.With ステートメントを使って、メソッドやプロパティに与える命令や値を最短にする。  (文字列を減らす。不要なコメントは入れない。) 2.シートやブックは、オブジェクト変数を使用する。Set wb =Workbooks("Book1.xls") 3.For Each ... Next ループを利用できれば使う。 4.Loop に与えるプロパティの値を、プロパティで与えないこと。   For i = 1 to Worksheets("Sheet2").Cells(1,5).Value '←予め変数を取り、変数で与える 5.自動キャストを使わない。Variant型出力を、文字、数値に指定する。明示的にプロパティを指定する。  例: Cells(1, "A"), Range("A" & i ) ....Cellsの引数は数値。Rangeの引数は、文字か、Cellsプロパティ 6.コレクション(Sheets, Workbooks)は、名前よりも、インデックスが速い 7.ワークシートのメソッドは、VBAでは必ずしも必要としない。代表的なものは、Select, AutoFill 8.マクロ記録で不要な部分を、そのままにしない。Default値のままのものは、その部分を削除する。 9.変数は、Variant型は控えめにする。固有のオブジェクト型を使う。定数を利用する。配列を利用してメモリから値を取り出す。文字列関数で、文字列を与えるなら、文字列出力にさせる。使わない変数は削除する。 10.画面を更新させない。割り込み(Event, DDE)はさせない。 11.ワークシート内のセルをループさせない方法はないか探す。 12.メイン・プロシージャーは短めに、サブルーチンを使用する。 13.実行時バインディングをやめて、事前バインディングを使う。 14.コードを改編しない場合、VBEオプションを「バックグラウンド コンパイル」にしておく。(ただし、コードを良く改編する人には向きません。) 以下はAccessのヘルプですが、こういう内容が出ています。

参考URL:
http://office.microsoft.com/ja-jp/access-help/HP005186823.aspx?redir=0
wellfield
質問者

お礼

Wendy02さん、GOCHSOUdaさん いろいろアドバイスを頂きありがとうございます。内容については、理解できるもの、すでに利用しているもの、未だ利用したことなく不明なもの等ありますが、 この貴重なアドバイスを頂きましたので、今一度更に最適化出来ないか頑張ってみます。 ありがとうございました。

wellfield
質問者

補足

この掲示板利用が少ないため、このたび回答への投稿が思うようにいきませんでした。回答を下さった方には不快な思いをされたことと申し訳なく思っています。 どのようなことかと申しますと 全コード・サンプルを投稿しようとしますと字数が不足し、コードの一部分しか投稿できませんでした。このような場合の回避方法をご存知でしたら、教えていただけませんか?今後のためにも

回答No.1

内容については触れません。 変数をきちんと宣言して、Variantを避ける。 ScreenUpdatingで画面を固定する。 RangeよりCellsの方がすっきりするのでは。 >CoN = "D": C = 30       ’”D"は元データの納入先の・・・・・・ の30~’のスペースを止める。(見た目は犠牲) CoN = "D": C = 30 ’”D"は元データの納入先の・・・・・(次の行とか) With Worksheets("集計")は SnLaRow = Worksheets("集計").Range("A" & Rows.Count).End(xlUp).Row  ’コピー・・・ の前からで SnLaRow = .Range("A" & Rows.Count).End(xlUp).Rowのようにする。

wellfield
質問者

補足

GOCHISOUda さん 早速の回答ありがとうございます。 予め、すべてを質問すればよいものを一部分を投稿し、失礼しました。申し訳ございません。 実は、変数もScreenUpdatingも設定しています。ただ、 「RangeよりCellsの方がすっきりするのでは」の件は、そのときに使いやすいほうを今までは使っていました。このコードについて再考します。 体感的にもう少しせめて0.5秒以内とかには、むりなのでしょうか?

関連するQ&A

  • EXCEL VBA 早く処理をする

    よろしくお願いします 下の構文を標準モジュールに書き込み、callで実行しているのですが 処理に時間がかかります。 処理を早くする方法と構文の簡素化のご教示をお願いします。 Application.ScreenUpdating = False For i = 1 To 12 With Worksheets(i) .Select LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending .Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8" LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A" & LastRow).Select Dim EndRow As Long EndRow = .Range("A" & Rows.Count).End(xlUp).Row Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計" Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7") Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計" Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6) .Range("C7").End(xlDown).Select Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin End With Next i Application.ScreenUpdating = True

  • VBA sumifで計算できません

    集計シートに入力シートから抽出した重複しない検索データの合計値を入力シートでSUMIFで書いてみましたが  「オブジェクトはこのプロパティまたはメソッドをサポートしていません。」とエラーになります。 何がいけないのか調べてみましたがVBA初心者でわからず困っています。 教えてください。よろしくお願いします。 Dim 集計データ数 As Long Dim 入力シートデータ数 As Long Dim データ行 As Long 集計データ数 = Cells(Rows.Count, 38).End(xlUp).Row 入力シートデータ数 = Worksheets("入力").Cells(Rows.Count,29).End(xlUp).Row For データ行 = 11 To 集計データ数 Cells(データ行, 11).Value = Application.WorksheetFunction.SumIf(Worksheets("入力").Range(Cells(11, 29), Cells(入力シートデータ数, 29)),Cells(データ行, 2), Worksheets("入力").Range(Cells(11, 21), Cells(データ行, 21))) Next データ行 End Sub

  • VBA 高速化

    以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

  • VBA 類似シート名 処理

    シート名が、「一覧 (2)」、「一覧 (3)」、・・・・・「一覧 (n)」、と連続する各シートの表データを「一覧」という名前のシートにまとめたいのですが、やり方が分かりません。 For Each を使えば出来るんじゃないかと調べましたが、見付けられませんでした。 シート処理以外は、   Dim CoR As Long, PaR As Long, PaR2 As Long CoR = Worksheets(???).Cells(Rows.Count, 1).End(xlUp).Row PaR = Worksheets("一覧").Range(Rows.Count, 1).End(xlUp).Row PaR2 = CoR + PaR + 1 Worksheets(???).Range(Cells(2, 1), Cells(CoR, 12)).Copy Worksheets("一覧").Range(Cells(PaR, 1), Cells(PaR2, 12)).PasteSpecial Paste:=xlPasteValues こんな感じで作っています。 作り方、もしくは参考になるサイトがありましたら、教えていただければありがたいです。 よろしくお願いします。

  • VBA 任意のシートからコピーを始める。

    教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i

  • EXCELのVBAでDcount関数がうまく動きません。

    EXCELのVBAでDcount関数を使おうとして、下記コードを作成しましたが、Dcount関数の部分が期待どおり動かず、該当なしとして、0を返してきます。 デバックで途中でマクロを止めて(Dcount関数の前)、セルに直接Dcount関数を入力すると、期待どおりの値を返してきます。 Dcount関数の記述の何が問題なのか、ご教示いただければ幸いです。 Sub 期間集計() Dim myrow, Krow As Double Dim First, Last As Date Dim i, Count As Integer Dim Data As Integer Dim Keria As String 'Worksheets("期間別").Activate Worksheets("期間別").Range("A1:BB65536").Delete Worksheets("入力").Activate With Worksheets("入力") '入力表の最終行の行数をmyrowに代入 myrow = .Range("A65536").End(xlUp).Offset(1).Row '出力前に入力データを日付順にソート .Range("A3").Sort _ Key1:=.Columns("A"), _ Header:=xlGuess First = Worksheets("集計").Range("G3") Last = Worksheets("集計").Range("H3") .Range("BH3:BH5").ClearContents .Range("BH3") = "日付" .Range("bi3") = "日付" .Range("BH4") = ">=" & First .Range("BI4") = "<=" & Last .Range(.Cells(2, 1), Cells(myrow, 47)).AdvancedFilter Action:=xlFilterCopy, _ Criteriarange:=.Range("BH3:BI4"), Copytorange:=Worksheets("期間別").Range("C11"), Unique:=False Krow = Worksheets("期間別").Range("C65536").End(xlUp).Row Keria = "C11:" & "AW" & Krow End With Worksheets("集計").Activate With Worksheets("集計") .Range(.Cells(13, 10), .Cells(24, 10)).ClearContents For i = 1 To 12 Count = 12 + i .Range(.Cells(Count, 16), .Cells(Count, 61)).Copy .Range(.Cells(11, 16), .Cells(11, 61)).PasteSpecial Paste:=xlValues .Range(.Cells(10, 16), .Cells(11, 61)).Copy With Worksheets("期間別") .Range(.Cells(11, 53), .Cells(12, 98)).PasteSpecial Paste:=xlValues Data = WorksheetFunction.DCount(.Range(Keria), .Range("C11"), .Range("BA11:CT12")) End With .Cells(Count, 10) = Data Next i End With

  • エクセルVBA の変数を使うべきでしょうか?

    はじめまして。エクセル初心者です。 書籍やサイトで勉強させてもらっていますが、VBAがなかなか難しくてすぐに壁にぶつかってしまいます。少々困ってしまい、詳しい方のアドバイスを頂ければと質問を投稿させていただきました。 どうか宜しくお願い致します。質問ですが、 以下のようなコードで、sheet5のB列の任意のセルをダブルクリックした場合、sheet5のBCD列の同じ行のセル値がsheet1の指定した列に入力されるという処理を作りました。 これで一応目的の動作はするのですが、数が増えると「コンパイルエラー・プロシージャが大きすぎます」というメッセージがでてしまいます。列や行には規則性があるので、もしかしたら変数というものを使ってコードを書き直せばいいのかなと思いネットで調べてみたのですが、今のところさっぱり理解できません。 申し訳ありませんが、分かりやすくご教授いただけないでしょうか。バージョンは2003を使っています。 また、下のコードですと、sheet5のBCDいずれかのセルに空白があった場合、sheet1の列に入力されるときに入力される行がずれてしまいます。今は空白を何かで埋めて対処しているのですが、この問題の解決策も教えて頂けると助かります。どうか宜しくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean) If Target.Address = "$B$2" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B2") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C2") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D2") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$3" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B3") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C3") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D3") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$4" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B4") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C4") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D4") Worksheets("sheet1").Activate cancel = True End If   ・     ・   ・     ・   ・     ・ End Sub

  • VBA 変数について

    VBA初心者でございます。 VBAでgrpという変数を設定し、それをキーにしてオートフィルタをしたいです。 以下のコードではエラーがでてしまうのは、なぜでしょうか? どうぞ宜しくお願いいたします。 Sub 絞り込み2() Dim grp Set grp = Worksheets("リスト").Cells(3, 2) Worksheets("マスタ0701").AutoFilterMode = False With Worksheets("マスタ0701").Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)) .AutoFilter Field:=13, Criteria1:=grp '.CurrentRegion.Select Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)).SpecialCells(xlVisible).Copy Worksheets("検索結果").Range("A1") '.AutoFilter End With End Sub

  • エクセルVBAにて

    エクセルのVBAにて irow=Cells(Rows.Count,1).End(xlUp).Row irowは整数型として宣言している変数です。 という記述の場合、どのような内容を表しているのでしょうか? 特に、Cells~Endの前までの記述がよく分からないのですが・・・ よろしくお願いします。

  • エクセルで集計表を作成するマクロで悩んでいます。

    エクセルで集計表を作成するマクロで悩んでいます。 日付ごとにシート別に分かれたデータを「集計表」として新しいシートに集めたいと思っています。 ●元データに関して  1行目は空欄  2行目は表の名前  3行目は日付  4~7行目は番号・数量などの項目  8行目から多い場合で50行目くらいまで番号ごとの情報が並んでいます。  AC列まで並んでいます。・・・・・・●画像左上が元データ ●このファイルから、(1)集計表という新しいシートを作成して(2)そのファイルに日付ごとの データが下方向に集まるように集計したいと思っています。 そこで、次のVBAを作成しました。 Sub 集計表() Dim ws As Worksheet For Each ws In Worksheets ’AD列にシート名を入れる ws.Range("AD1:AD100").Value = ws.Name Next ws Dim newSh As String Dim Sh As Worksheet, myFlag As Boolean newSh = "集計表" myFlag = False For Each Sh In ThisWorkbook.Worksheets If Sh.Name = newSh Then myFlag = True '----全データシートのデータをクリアし、先頭へ移動します Worksheets(newSh).Cells.ClearContents Worksheets(newSh).Move before:=Sheets(1) Exit For End If Next Sh '----全データシートを先頭へ追加します If myFlag = False Then ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh End If Worksheets(2).Select Rows("1:1").Select Application.CutCopyMode = False Selection.Copy Sheets("集計表").Select ActiveSheet.Paste Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long Application.ScreenUpdating = False '----列見出しをコピーします Worksheets(2).Range("1:1").Copy Worksheets(1).Range("A1") For i = 2 To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが8行以上の場合にコピーします If lRow >= 8 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i Worksheets(1).Activate Range("A1").Select Application.ScreenUpdating = True End Sub この方法だと、「番号」などを含むシートごとの全ての情報がコピーされてしまいます。 ●左下画像 これを「(1)1枚目のシートの1行目から7行目(2)1枚目シートの8行目からA列に1以上の番号が 入っている行(3)2枚目シートの8行目からA列に1以上の番号が入っている行(4)3枚目シートの・・・」というように全てのシートに対して集計することはできないでしょうか。 ●右下画像 VBAを始めたばかりなので、まだ、あまり理解できていません。

専門家に質問してみよう