[[20150722133705]]　『Do While を使って別シート二つから、セルをコピ＝x（橘）　ページの最後に飛ぶ

『Do While を使って別シート二つから、セルをコピーしたい』（橘）

VBAについての質問です。いまマクロの作成で、セルを提供するシートが二つ、セルがコピーされるシートが一つと、合計3つのシートがあります。

これらを仮に、『セルを提供するシート』をそれぞれ「提供シート1」「提供シート2」、
『セルがコピーされるシート』の名前を『取得シート』とします。

提供シート1は

年月日種類ジャンル

2015 7 21 収入給与
2015 7 22 収入給与
2015 10 5 収入給与
2015 11 6 収入その他
2015 12 6 収入その他
　　　　　　　　・
　　　　　　　　・
　　　　　　　　・

となり、提供シート2は

年月日種類ジャンル

2015 7 21 支出給与
2015 7 22 支出食費
2015 7 23 支出給与
2015 7 24 支出給与
2015 7 25 支出水道光熱費
2015 7 26 支出給与
　　　　　　　　・
　　　　　　　　・
　　　　　　　　・
とします。

ここから、取得シートが

            2015年7月

No. 日にち収支ジャンル
1 22 収入給与
2 23 収入給与
3 24 収入給与
4 25 収入給与
5 26 支出水道光熱費
6 27 支出食費
7 28 収入その他
8 1 収入その他
　　　　　　　　・
　　　　　　　　・
　　　　　　　　・
といった具合にセルをコピーしたいと考えています（上記はイメージです）

取得する基準は、「取得シート」上部の「○○年○○月」が、提供シート内それぞれが持つ年月と一致した横列を取得したいと考えております。

年と月はYearとMonthで取得できるところまでは分かりましたが、複数のシートをループ分で参照する方法が分からずに困っている状況です。

今考えているのは、Do While 提供シート二つを選択セルが空白になるまでループさせて、そのループで条件一致した列のデータを取得シートのセルに当てはめるというイメージです。

そのDo While にかんしても、シート一つにつきDo While を作った方がいいのか、
一回のDo While で複数のシートが見れるかのかが分からない状況です。

参考元のＵＲＬはこちらです。http://officetanaka.net/excel/vba/tips/tips123c.htm
こちらのページのように、コピーをしたいのですが、複数のシートを同時にループできればと思います。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

こんにちは

Do While を使わずに、２つのシートに対してそれぞれオートフィルタで絞り込んでコピー
するのはどうでしょうか？

（ウッシ） 2015/07/22(水) 17:00

 >>そのDo While にかんしても、シート一つにつきDo While を作った方がいいのか、 
 >>一回のDo While で複数のシートが見れるかのかが分からない状況です。

 とりあえず、ここだけコメントします。
 複数のシートは当然行数が異なるわけですから、どれだけ（何回）ループさせたらいいか、それはシート毎に、異なりますよね。

 ですから、１回の Do/Loopですべてのシートを処理しようとするのは【無茶】です。

 仮に無茶を承知で、こういったコードを書き上げたとしても、実際のコード実行数はほとんど
 変わりません（つまり、処理時間はかわらない）し、マクロのコード数そのものでも、シート毎にループ処理をさせても
 書き方の工夫で、１回のループと、そんなにかわらない組み立てもできます。

 あるいは、各提供シートを、別途作業用シートに転記し、そのシートを【本当の１回のループで】処理することも
 考えられますね。

 これを延長すると、各提供シートを、取得シートにすべてコピーして、そこで条件にあわないものを削除するというのも
 考えられますね。

 ただ、処理効率のことを考えると、ウッシさん指摘のように、オートフィルター、あるいはフィルターオプションといった
 フィルター系の処理がおすすめですね。

 それとは別に、処理起動方法としては

 ・取得シートの年月欄に入力してからマクロを実行させる。
 ・取得シートの年月欄に入力があった時点で自動的に実行させる。

 が、考えられますね。

（β） 2015/07/22(水) 20:11

 フィルターオプションを使ってみました。
 取得シートの E～G列を作業域に使います。
 フィルターオプションの場合、セルに条件を記述する必要上、コードが多くなる印象ですが
 実際の比較抽出はループなしで１コードで実行していますので効率は優れています。
 このコードでは、
 ・すべての提供データを取得シートにコピーし
 ・条件に合わないものを抽出して
 ・それを削除（結果的に条件に合うものが残る）
 こんな処理をしています。

 Sub Sample()
    Dim sv As Variant
    Dim shG As Worksheet
    Dim sh As Variant
    Dim yy As Long
    Dim mm As Long
    Dim listR As Range

    Application.ScreenUpdating = False

    Set shG = Sheets("取得シート")
    yy = Year(shG.Range("A1"))              '★
    mm = Month(shG.Range("A1"))             '★
    sv = shG.Range("A1:E2").Value           'タイトル部分の保存
    shG.UsedRange.Offset(2).ClearContents   'データ領域クリア

    For Each sh In Array(Sheets("提供シート1"), Sheets("提供シート2"))
        shG.Range("A2:E2").Value = sh.Range("A1:E1").Value      'タイトルコピー
        sh.Range("A1").CurrentRegion.Offset(1).Columns("A:E").Copy shG.Range("A" & Rows.Count).End(xlUp).Offset(1)
    Next
    '検索条件
    shG.Range("G1").ClearContents
    shG.Range("G2").Value = "=A3&CHAR(2)&B3<>" & yy & "&CHAR(2)&" & mm
    'フィルターオプション実行
    Set listR = shG.Range("A2", shG.Range("A" & Rows.Count).End(xlUp)).Resize(, 5)
    listR.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=shG.Range("G1:G2"), Unique:=False
    '抽出領域削除
    If listR.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        Intersect(listR, listR.Offset(1)).EntireRow.Delete
    End If
    'フィルター状態のリセット
    If shG.FilterMode Then shG.ShowAllData
    'A列連番
    With listR.Columns(1).Offset(1).Resize(listR.Rows.Count - 1)
        .Cells(1).Value = 1
        .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    '復元
    shG.Range("G1:G2").ClearContents
    shG.Columns("B").Delete
    shG.Range("A1:E2").Value = sv
    shG.Select

 End Sub

（β） 2015/07/22(水) 21:22

 アップ済みのSampleとの違いをより明確にするため、コードを少しいじりました。（7/23 6:46)

 ループ版も参考まで。（Do/Loopではなく For/Nextを使っていますが）

 コード量は少なくなりますが、効率は、アップ済みのものと比較して格段に劣ります。
 （この形で、もう少し効率アップということは可能ですが）

 Sub Sample2()
    Dim shG As Worksheet
    Dim sh As Variant
    Dim yy As Long
    Dim mm As Long
    Dim listR As Range
    Dim i As Long
    Dim x As Long
    Dim seq As Long

    Application.ScreenUpdating = False

    Set shG = Sheets("取得シート")
    yy = Year(shG.Range("A1"))              '★
    mm = Month(shG.Range("A1"))             '★
    shG.UsedRange.Offset(2).ClearContents   'データ領域クリア
    x = 3     '転記開始行
    seq = 1   'A列連番

    For Each sh In Array(Sheets("提供シート1"), Sheets("提供シート2"))
        For i = 3 To sh.Range("A" & Rows.Count).End(xlUp).Row
            If sh.Cells(i, "A") = yy And sh.Cells(i, "B").Value = mm Then
                shG.Range("A" & x).Value = seq
                shG.Range("B" & x).Resize(, 3).Value = sh.Range("C" & i).Resize(, 3).Value
                x = x + 1
                seq = seq + 1
            End If
        Next
    Next

    shG.Select

 End Sub

（β） 2015/07/22(水) 21:45

 ウッシさんが示唆されたオートフィルター版、正攻法（？）で、該当のものを抽出して転記します。
 (16:58 ちょこっと修正)

 Sub Sample3()
    Dim shG As Worksheet
    Dim sh As Variant
    Dim yy As Long
    Dim mm As Long

    Application.ScreenUpdating = False

    Set shG = Sheets("取得シート")
    yy = Year(shG.Range("A1"))              '★
    mm = Month(shG.Range("A1"))             '★
    shG.UsedRange.Offset(2).ClearContents   'データ領域クリア

    For Each sh In Array(Sheets("提供シート1"), Sheets("提供シート2"))
        sh.AutoFilterMode = False
        '年月絞り込み
        sh.Range("A1").AutoFilter Field:=1, Criteria1:=yy
        sh.Range("A1").AutoFilter Field:=2, Criteria1:=mm
        '抽出があればコピペ
        If sh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 0 Then
            Intersect(sh.AutoFilter.Range, sh.AutoFilter.Range.Offset(1)).Columns("C:E").Copy shG.Range("B" & Rows.Count).End(xlUp).Offset(1)
        End If
        sh.AutoFilterMode = False
    Next

    If Not IsEmpty(shG.Range("B3")) Then
        'A列連番
        With shG.Range("B3", shG.Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
            .Cells(1).Value = 1
            .DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
        End With
    End If

    shG.Select

 End Sub

（β） 2015/07/23(木) 15:52

コメント返信：

[ 一覧(最新更新順) ]

[[20150722133705]] 『Do While を使って別シート二つから、セルをコピ＝x（橘） ページの最後に飛ぶ

[[20150722133705]]　『Do While を使って別シート二つから、セルをコピ＝x（橘）　ページの最後に飛ぶ