シート別高速処理VBA

Question

実現したいこと

集計表.xlsmからVBAを実行し、工程表_2022年4月.xlsmの所定シート（04から始まるシート名）の所定項目を集計表.xlsmへ全て転記したい。

●集計表.xlsm※完成状態

●工程表_2022年4月.xlsm

●フォルダ構成

条件

・工程表_2022年4月.xlsmシート数は、0401～0428まで存在する。※1日1シート存在
・上記各シートは、添付画像と同じデータが入っている。

試した事・発生している問題・エラーメッセージ

現状、for文、if文で一行ずる処理コードしか出来ていない為、処理時間にかなり時間をようしてしまっているので、高速処理できるように解消したくご協力をお願いします。
→連想配列も考えたのですが、データ自体が重複している為キーを設定する事が出来ませんでした。※私の知識の中ですが。

エラーメッセージ

該当のソースコード

Sub シート集約()
Dim source As String        '転記元ファイル保管パス
Dim cWb As Workbook     '転記先ファイル変数
Dim cWs As Worksheet     '転記先シート変数
Dim cWc As Range            '転記先該当ファイル名
Dim cWc1 As Range            '転記先該当シート名月
Dim cWc2   As Range         '転記先該当シート名年
Dim rowAc As Long            '転記先A列行番号
Dim sWb As Workbook     '転記元ファイル変数
Dim sWs As Worksheet    '転記元シート変数
Dim sWc As String           '転記元ファイル名
Dim sWc1 As String          '転記元シート名
Dim sWc2 As String          '転記元シート名頭2桁
Dim rowA As Long            '転記元A列行番号

Application.ScreenUpdating = False    '画面チラツキ防止

source = "C:\Users\xxx\Desktop\共通\50_VBA\シート別高速処理" 'パスは身バレの為、xxxと表現
Set cWb = ThisWorkbook
Set cWs = cWb.Worksheets("Sheet1")
Set cWc = cWs.Range("A1")
Set cWc1 = cWs.Range("A2")
Set cWc2 = cWs.Range("C2")
Set sWb = Workbooks.Open(source & "\" & cWc, UpdateLinks:=False)
cWs.Rows("3:" & Rows.Count).ClearContents 'データ削除

For Each sWs In Worksheets
    If Left(sWs.Name, 2) = cWc1 Then
        maxrowA = sWs.Cells(Rows.Count, "A").End(xlUp).Row
        For rowA = 5 To maxrowA
            maxrowAc = cWs.Cells(Rows.Count, "A").End(xlUp).Row
            cWs.Cells(maxrowAc + 1, 1) = sWs.Cells(rowA, 1)   '型
            cWs.Cells(maxrowAc + 1, 2) = sWs.Cells(rowA, 2)   '品番
            cWs.Cells(maxrowAc + 1, 3) = sWs.Cells(rowA, 3)   '品名
            cWs.Cells(maxrowAc + 1, 4) = sWs.Cells(rowA, 6)   '組立着手日
            cWs.Cells(maxrowAc + 1, 5) = sWs.Cells(rowA, 7)   '組立完了日
            cWs.Cells(maxrowAc + 1, 6) = cWc2 & "年" & cWc1 '転記元シート年月
        Next
    End If
Next

sWb.Close
Application.ScreenUpdating = True    '画面チラツキ防止

End Sub

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

Comments

[Usirow]

連想配列を使うなら、Keyは適当な連番にして、Itemにデータを入れればいいのではないでしょうか。

[jabe]

回答ありがとうございます。
ユニークキーを持つ必要があるってことですね。

Answer 1

そのまま転記するだけなら連想配列とか不要です。

        maxrowA = sWs.Cells(Rows.Count, "A").End(xlUp).Row
        For rowA = 5 To maxrowA
            maxrowAc = cWs.Cells(Rows.Count, "A").End(xlUp).Row
            cWs.Cells(maxrowAc + 1, 1) = sWs.Cells(rowA, 1)   '型
            cWs.Cells(maxrowAc + 1, 2) = sWs.Cells(rowA, 2)   '品番
            cWs.Cells(maxrowAc + 1, 3) = sWs.Cells(rowA, 3)   '品名
            cWs.Cells(maxrowAc + 1, 4) = sWs.Cells(rowA, 6)   '組立着手日
            cWs.Cells(maxrowAc + 1, 5) = sWs.Cells(rowA, 7)   '組立完了日
            cWs.Cells(maxrowAc + 1, 6) = cWc2 & "年" & cWc1 '転記元シート年月
        Next

上記のループで1行ずつ転記しているところを、まとめて転記するようにすれば高速化されるでしょう。

            maxrowA = sWs.Cells(Rows.Count, "A").End(xlUp).Row - 4
            maxrowAc = cWs.Cells(Rows.Count, "A").End(xlUp).Row
            cWs.Cells(maxrowAc + 1, 1).Resize(maxrowA, 3) = sWs.Cells(5, 1).Resize(maxrowA, 3)
            cWs.Cells(maxrowAc + 1, 4).Resize(maxrowA, 2) = sWs.Cells(5, 6).Resize(maxrowA, 2)
            cWs.Cells(maxrowAc + 1, 6).Resize(maxrowA, 1) = cWc2 & "年" & cWc1

追記

cWs.Cells(maxrowAc + 1, 1).Resize(maxrowA, 3) = sWs.Cells(5, 1).Resize(maxrowA, 3)は省略せずに記述すると、
cWs.Cells(maxrowAc + 1, 1).Resize(maxrowA, 3).Value = sWs.Cells(5, 1).Resize(maxrowA, 3).Valueとなります。
セル範囲のValueプロパティは二次元配列を返します。
今回のように何も加工せずに転記する場合は、そのまま代入すれば、セル範囲が一度に転記できます。
セル範囲の値を加工して転記したい場合は、二次元配列の変数に代入してから、それを加工して、転記先のValueに代入するということをします。
加工せずに転記する場合は、二次元配列の変数を使う必要はないです。

Comments

[jabe]

対応ありがとうございました。
早く処理できるようになりました。
resizeでコピー貼付なるほどです、使わせていただきます。

Answer 2

ループでまわすと遅くなります。
各シート先頭行は決まっていて、データの最終行の情報だけ入手して
そのデータ範囲を二次元配列に格納します
二次元配列に格納したデータを集計表に貼り付け・・・で
既存の処理より早く処理できます

Comments

[jabe]

回答ありがとうございます。
hatena19さんのやり方で取得したデータを配列に格納するって事ですか？