当月分集計シートから日にち別シートを作成するには?

Question 82.4 Excel VBA Borad (掲示板)より Previous Next
クリックで拡大可能 (投稿画像) 初めて書き込みさせていただきます。
表のデータを、複数のシートにコピーするやり方を教えていただけないかと思い、書き込みさせていただきました。
よろしくお願い致します。

右図の1、2、31のシートのようなシートが、本来は31枚ありますが、省略してあります。 他の日も同様、数量の入っているもののみ、各シートにコピーしたいです。

実は、修正できないかと親に言われて、先週エクセルの本を買ったばかりの初心者で、まだ元のファイル(各シートに入力されたものを集計するマクロ)もいまいち理解できていない状況です。
本に、「開いたブックの内容を転記する」
With ThisWorkbook.Worksheets(1)
    .Cells(2, 1) = ブック.Worksheets(1).Range("B4").Value
    For j = 1 To 5
        .Cells(2, j + 1) = ブック.Worksheets(1).Cells(7, j).Value
    Next
End With
とあったため、 指定したセルの内容を他のシートの指定したセルへそのままコピーするやり方はこれを応用すればいいのかなと思ったのですが、どう変更すればいいのかがわかりません。
また、
値が入った行のみコピーをどうすればわかりません。 (IsEmptyでなんとかならないのかと思ったのですが、どう応用すればいいのかがわかりません。)
また、For文で31回繰り返せばいいのかと思ったのですが、セルやシートをひとつづつどう増やせばいいのかわかりません。
また、
転記先の表も20個以上は(同じシート内の)隣の表になるため、そのやり方もわかりません。
わからないことだらけで、自分で書いていて、この状態で人に教えてもらおうなんてずうずうしいなと思いましたが、ご教授いただけると助かります。よろしくお願い致します。
Answer   Copyright (C) 2007.7.10 永井善王
親御さんの要請に、買った本に載っているマクロを活用すれば応えられるのではと、いろいろ検討なさったのですね。

仰るとおり「開いたブックの内容を転記する」というマクロを使おうとすると、
値が入った行のみコピーするための工夫が必要になります。
その工夫は、ワークシート関数の ISBLANKで空白セルを判定することによっても可能になります (※) が、あなたが示された図によると、処理対象セルが相当多い (2000×31=約62000件) ので、For...Next文による繰り返し処理でない方が賢明でしょう。

あれこれ悩んでいると、なかなか進みませんね。
こういう場合は、細かいことを後回しにして、大筋から考えるといいですよ。 「For文で31回繰り返せばいいのかと思った」線でドカンと進みましょう。 考え方をご説明します。

(注) 「
転記先の表も20個以上は(同じシート内の)隣の表になる」とのことですが、「本来は31枚ありますが…」とか、図には「31」シートがあったりして判断に困りますが、「1」から「31」までの31シートがある前提で進みます。
7月分シート
1. 「7月分」シートから品名と「1」の個数をコピーして、「1」シートへ貼り付けしてしまいます。
とりあえず、右図のように約2000行全部をコピーして、値を貼り付けするマクロを記録します。 空白セルかどうか細かいことは置いておきましょう。

2. 記録したマクロに For...Next文を組み込みます。
「31回繰り返せばいい」です。 「セルやシートをひとつづつどう増やせばいいのか」は置いておきましょう。

3. 作成したマクロを実行してみます。
実行すると「7月分」シートから「1」シートへ品名と個数が、バカ正直に31回、コピー貼り付けされましたね。 「2」シートから「31」シートの状態は何も変わっていませんね。

ドカンと作成したこのマクロをよく読んで、1行1行のコードとエクセルの動きが結びつくように、努力して理解してください。

結論に入ります。
以下に本格的に作成したマクロをお示しします。
「先週エクセルの本を買ったばかりの初心者」さんとのこと、まずはサンプルブックをダウンロードしてマクロを実行してみてください。

コードの理解は、その後でコツコツ、時間をかけて進まれると良いかと思います。
全部の解説は大変長くなるので出来ませんが、ポイントをまとめておきますから参考にしてください。

 ・月分シートの n日分を数量が空白以外の行をオートフィルターで抽出する
 ・フィルタした結果のデータ部だけを作業シートへコピーする
  (作業用シートはマクロの始めで挿入し、終わりに削除する)
 ・作業用シートの品名と数量を日別シートへコピーする
 ・以上の処理を末(31)日になるまで繰り返す
Option Explicit
Dim 月分シート, 作業シート
Dim 日別シート, 日別シート摘要セル範囲
Dim 末日, カウンタ, データ数, 下端行, 抽出列
Dim 結果
'-------------------------------------------------------------------------------
Sub 当月分集計シートから日にち別シートを作成する()
    月分シート = "7月分"                                '月分シートの名前
    日別シート摘要セル範囲 = "B13:Q19"                  '日別シートの摘要のセル範囲
    末日 = Worksheets(月分シート).Range("B4").End(xlToRight).Column - 2 '右端-2
    Application.ScreenUpdating = False                  '画面を更新しない
    作業用にシートを挿入する
    For カウンタ = 1 To 末日                            '1日から末日まで繰り返す
        数量が空白以外の行をフィルタしデータ部だけを作業シートへコピーする
        If データ数 <> 0 Then                          'その日のデータ数が0でなければ
            作業シートの品名と数量を日別シートへコピーする
        End If
        Worksheets(月分シート).AutoFilterMode = False   'フィルタモードを解除
    Next
    作業シートを削除する
End Sub
'-------------------------------------------------------------------------------
Private Sub 作業用にシートを挿入する()
    Worksheets.Add
    作業シート = ActiveSheet.Name
End Sub
'-------------------------------------------------------------------------------
Private Sub 数量が空白以外の行をフィルタしデータ部だけを作業シートへコピーする()
    Worksheets(作業シート).Cells.Clear                       '全てのセルを全てクリア
    With Worksheets(月分シート)
        .Activate
        抽出列 = 1 + カウンタ                                 'フィルタする列(1=B列)
        .Range("B4").AutoFilter Field:=抽出列, Criteria1:="<>" '空白以外を抽出
        Set 結果 = .AutoFilter.Range
        データ数 = 結果.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
        If データ数 <> 0 Then                                 'データ数が0でなければ
            Set 結果 = 結果.Resize(結果.Rows.Count - 1).Offset(1) 'データ部だけに
            結果.Copy Destination:=Worksheets(作業シート).Range("B5") 'コピー
        End If
    End With
End Sub
'-------------------------------------------------------------------------------
Private Sub 作業シートの品名と数量を日別シートへコピーする()
    日別シート = LTrim(Str(カウンタ))
    Worksheets(日別シート).Range(日別シート摘要セル範囲).ClearContents    'クリア
    下端行 = Worksheets(作業シート).Range("B" & Rows.Count).End(xlUp).Row '下端
    Worksheets(作業シート).Activate
    Range(Cells(5, 1 + 抽出列), Cells(下端行, 1 + 抽出列)).Copy           '数量コピー
    Worksheets(日別シート).Range("P13").PasteSpecial Paste:=xlPasteValues '貼付
    Range("B5:B" & 下端行).Copy                                           '品名
    Worksheets(日別シート).Range("C13").PasteSpecial Paste:=xlPasteValues
End Sub
'-------------------------------------------------------------------------------
Private Sub 作業シートを削除する()
    Application.DisplayAlerts = False           '注意メッセージを表示しない
    Worksheets(作業シート).Delete
    Application.DisplayAlerts = True
End Sub
※ 参考
・指定したセルが空白セルか調べる … Excel VBAマクロ組み方講座 プロの定番・裏技・合わせ技編 P.061
・オートフィルターして結果のデータ部だけをコピーする … 同上 P.117
ISBLANK関数の対象セルを指定するコードの書き方は?

サンプルブックのダウンロードは ここをクリック  (YNxv991132_Copy.xls 61KB)
※ 一旦、ブックをハードディスクに保存し、後で改めて開いてから実行してください。


 

Excel VBA Macro