Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2016)
2次元配列をコレクションに格納する方法
投稿日時: 21/01/08 17:55:43
投稿者: torao

セル範囲のテストデータを配列に格納しそれをコレクションに格納しようとしております。
 
コレクションに配列データをループで3回格納すると
For i = 1 To 3
    cData.Add Item:=tmp
Next i
 
コレクション内のItemが3つできます。
Item1
Item2
Item3
 
質問は
 
配列データ要素×3ループ分を全てItemとして格納したいのですが、処理の方法がわかりません。
 
(説明がうまくできないため下記に現在の状況と、どのようにしたいのかを記載します)
 
Sub 配列をコレクションに統合()
    Dim r As Long: r = Cells(Rows.Count, 1).End(xlUp).Row
    Dim c As Long: c = Cells(1, 36).End(xlToLeft).Column
  '配列/テストデータ
    Dim tmp As Variant: tmp = Range(Cells(2, 1), Cells(r, c)).Value
  'コレクション
    Dim cData As Collection: Set cData = New Collection
 
  '同じ配列データを3回コレクションに転記
    Dim i As Long
    For i = 1 To 3
        cData.Add Item:=tmp
    Next i
Stop
 
End Sub
 
 
(現在)
ローカルウィンドウで見ると以下のとおり
※4階層あり
─cData
 ├Item1
   ├Item1(1)
   ├Item1(1,1) aaa
     ├Item1(1,2) bbb
     ├Item1(1,3) ccc
 ├Item2
   ├Item2(1)
   ├Item2(1,1) aaa
     ├Item2(1,2) bbb
     ├Item2(1,3) ccc
 ├Item3
   ├Item3(1)
   ├Item3(1,1) aaa
     ├Item3(1,2) bbb
     ├Item3(1,3) ccc
 
 
(こうしたい)
ローカルウィンドウで見ると以下のとおり階層を繰り上げる
※3階層に繰り上げ
─cData
 ├Item(1)
 ├Item(1,1) aaa
  ├Item(1,2) bbb
  ├Item(1,3) ccc
 ├Item(2)
 ├Item(2,1) aaa
  ├Item(2,2) bbb
  ├Item(2,3) ccc
 ├Item(3)
 ├Item(3,1) aaa
  ├Item(3,2) bbb
  ├Item(3,3) ccc
 
 

回答
投稿日時: 21/01/08 18:01:49
投稿者: WinArrow
投稿者のウェブサイトに移動

コレクションではなく、
普通の配列を使えば?

投稿日時: 21/01/08 18:54:19
投稿者: torao

WinArrow さんありがとうございます。
 
 
 具体的には工程1〜3を処理しています
 
 1 フォルダ内のBOOKを開き
 
 2 指定シートのデータを配列に取り込んで
 
 3 作業シートに転記(又は追記)
  ※フォルダ内のデータ転記終了
 
 4 作業シートのデータ形成
 
現在上記のような処理を行っております。
質問に記載しておりませんでしたが
 
 ・工程3〜4をコード内で処理できないかと検討していたところ
 ※配列には行数を追記していくことができないとの記事があり
 
 ・作業シート代わりにCOLLECTIONを使用し配列データを順次格納していこうと考えました。
 ※SELECTIONは配列のようにデータ個数をしてしなくても自動で拡張してくれるとあったため
 
データ形成はCOLLECTIONから配列に格納しなおして完成したデータをシートへ転記します。
できれば、COLLECTIONを使用せずに配列だけでできれば、助かるのですが、行き詰まりです。
 
 

回答
投稿日時: 21/01/08 20:21:32
投稿者: simple

横入りします。
 
同じ配列を何回もCollectionに入れる意味も不明ですし、
ローカルウインドウ上の表示の何が問題なのか、正直よくわかりませんでした。
 
一般的な感想ですが、
・配列にする利点としては、一括して書き込むことによるスピードアップがあげられます。
・しかし、Collectionを一括して書き込むことはできませんし、
・処理内容によっては、配列化することによって、処理しにくくなることもあるかもしれません。
 
もうすこし、具体的な実例をあげていただいて、
困っている点を説明されたらどうですか?
文章では少し書いて頂いていますが、イメージが湧きにくいです。
(実例といっても字義どおり現物である必要はなく、簡略化したもので結構です。
  ただし、余り簡略化しすぎて問題の構造がなくなるようなものは適当ではありません。)

回答
投稿日時: 21/01/08 22:38:37
投稿者: WinArrow
投稿者のウェブサイトに移動

>※配列には行数を追記していくことができないとの記事があり
 
ここのところだけの対応例
 
ユーザー定義型を使う方法も検討してみれば?
Public ype typedataB
    datab1 As String
End Type
 
Public Type typeDataA
    dataa1() As typedatab
End Type
 
 
Dim Data1() AS typedataA
 
 
使い方
    data1(i).dataa1(j).datab1 = "AAA"
 
仮想二次元

投稿日時: 21/01/09 00:24:22
投稿者: torao

simple さま
 
何を質問したいのか整理できておりませんでした。すみません。
 
COLLECTIONを配列に変換することはできました。中身は3次元配列。
 
その、3次元配列を2次元配列に変換して格納できないかということでした。
 
ネットで調べて挑戦したいと思います。
 
 
WinArrow さま
 
ユーザー定義でどんな事ができるのか、まずは調べたいと思います。

回答
投稿日時: 21/01/09 06:36:25
投稿者: simple

なかなか話が噛み合いませんね。
 
> COLLECTIONを配列に変換することはできました。中身は3次元配列。
> その、3次元配列を2次元配列に変換して格納できないかということでした。

とのこと。
 
> COLLECTIONを配列に変換する
は言葉どおり、Collectionをもとに配列を新たに作ったんですか?
それとも、
最初の投稿(投稿日時: 21/01/08 17:55:43)でのコードの説明ですか?
そうであれば、Collectionの要素は、3次元ではないですよ。
今でも二次元配列を要素に持つCollectionになっています。
 
Collectionは、文字列のkeyを指定して、対応する値を保持することができます。
ただし、提示されたコードのように、keyを特に指定せずに使うと、
1からはじまる整数インデックスがkeyとして自動的に使われます。
 
したがって、今のコードは、
・1 という keyに対して、
  tmp = Range(Cells(2, 1), Cells(r, c)).Valueという二次元の配列が Itemに保持されています。
・2 という keyに対して、
  tmp = Range(Cells(2, 1), Cells(r, c)).Valueという二次元の配列が Itemに保持されています。
・・・ 以下同じ。
ということになっていて、これは3次元配列ではないんですよ。
今でもCollectionの中身のそれぞれのItemは、2次元配列です。
(key部分を一次元と数えるなら、実質的に3次元かもしれませんが)
 
----------------------
>※配列には行数を追記していくことができないとの記事があり
この意味は、
Redim Preserve を使って、配列を拡張していくときに、
列を増やすことはできても、行を増やすことはできない。
という話をしているんですよね。
 
3つの配列を一つの配列にまとめていきたい、
というのが質問の趣旨なら、以下のようにしたらどうですか?
 
予め3つの配列の大きさを調べて、まとめたときの配列の合計の行数を予め計算したうえで、
その大きさの配列を宣言して(Redim使用)、そこに各配列の要素を順次転記していく、
ということになるでしょう。
 
-----------------------
ただし、上記のように、配列の要素ごとに一つずつ転記していくのは
それなりに負荷があるかもしれません。
また、ひとつの大きな配列にすれば、確かにシート書き込みは効率的になりますが、
各種のデータ処理が別途あるとすると、
必ずしも配列上で実行するのがベストなのか検討の余地があります。
 
そうした意味から、私は、
されたいことをもっと前の段階に遡って、実例つきで説明した方がよいのでは、
と申し上げたのです。
 
そのほうが、具体的なコードでの議論もできるでしょうし、
色々なアイデアが寄せられると思ってお願いしたのですが、残念ですね。

回答
投稿日時: 21/01/09 09:10:32
投稿者: mattuwan44

難しく考えなくても、
順次シートにコピペを繰り返されればいいかと。。。。
 
処理の高速化をもくろんでおられると思いますが、
 
配列変数に追記していくより速いと思います。(データ量にもよりますが)
 
まずはやってみて、それに対して改善案を聞いてみては?
 
コレクションでもできなくはないでしょうが、
ループの回数が増えるだけです。
同じことをするなら処理時間は、
 
VBAで書いたマクロ(高級言語)>エクセルの各機能(低級言語)
 
VBAとかは翻訳(コンパイル)の時間が余分にかかるので、
感覚的に、VBAでループの処理を書かない(エクセル君が出来るところはエクセル君に任せる)
ようにした方が高速かなと思います。

回答
投稿日時: 21/01/09 11:10:57
投稿者: Suzu

みなさんが既におっしゃられている事と重複する部分がありますが
 
【1】配列を使用したい、コレクションを使用したい理由は何でしょうか。
【2】4階層から3階層にしたい理由は何ですか。
 
 
【1】 に関しては、処理速度の向上ではないかと推測します。
回答者の方々が既に書いてくださっていますが、
セル処理にて遅いのは、個々のセルにそれぞれ値を書き込む処理です。
個々のセルに対しての読み込み/配列の要素 の読み込み は 速度的に 大差は出ません。
 
Office TANAKA -【配列を使う】
http://officetanaka.net/excel/vba/speed/s11.htm
 
 
なので、セルの個々の値に対し書き込み処理をする場合において
セルに書き込む値を、計算し都度セルに書き込むのではなく
セルに書き込む値を、計算し配列に入れ、全計算が終わった後に配列の値をセルに一括で書き込むのです。
 
セルに値を一括で書き込めるので、配列を使用します。Range("A1:C3") = tmp の様に
しかし、セルに対し、コレクションを 一括で書き込む方法はありません。
 
行うのであれば、コレクションから、配列に変換してからになります。
 
 
セルの値の書き込みが目的であれば
1.コレクションにセルの値を代入
2.コレクションを変換
3.コレクションを配列に変換
4.配列をセルに代入
 
の流れになります。
 
コレクションを使用する為だけの為に、2と3 は余計な処理に見えませんか?
 
 
 
コレクションを3階層にしても、セルに直接代入はできません。
それを踏まえた上で、
【2】4階層から3階層にしたい理由は何ですか。
 
 
シートを、他のシートに統合、他に計算を行い計算結果をそのシートに書き込むのが目的なのであれば
1. シート内容を他シートの最終セルより下の位置にコピーする
2. セルの値を参照し、計算を行い 結果を配列に入れる
3. セルの特定位置に配列の内容を一括で書き込む
 
で良いと思います。
 
目的が違うのであれば、その旨を教えてください。

投稿日時: 21/01/09 14:26:01
投稿者: torao

皆様、すみません。混乱させているようで恐縮しております。
 
アドバイス取り、実際に使用しているコード全体を掲載させていただきました。
処理の流れは大まかに【1】〜【5】になります。
 
(処理概要)
 
 本コードのあるファイルと同じフォルダ内の「勤務表*.xlsm」とあるファイルが10コくらいあります。
 それを下記の順番で処理しております。
 
'【1】各種設定
'【2】フォルダ内の取込む対象ファイル(WbB)を参照し処理(WbBデータをWbAへ転記)
'【3】正常処理 指定シートがある場合 勤務表Dataを取り込み
'【4】シート転記処理 →(仕様変更中)COLLECTIONにデータを保留させる
'【5】最終処理 →(仕様変更中)シート転記・編集
 
(質問の内容)
 
 現在仕様を変更するにあたり
 ループ内で【3】で取り込んだデータを【4】で都度シートへ転記させておりますが
 多少の高速化とシートアクセスを減らしたく仕様変更しようと考えております。
 
 仕様変更後は
 ループ内で【3】で取り込んだデータを【4】でCOLLECTIONにデータを溜め込んで
 ループ終了後に【5】でCOLLECTIONを配列に変換しシートに一括で転記させようとしております。
 
 ※ネットでCOLLECTIONを調べるとシートにデータを書き出すには一旦配列に変換したほうが
  取り扱いがしやすいとの記事があり【5】で配列に変換することまで確認できました。
 
 どうしても分からない部分についての質問は
 
 COLLECTIONに格納したデータを配列に変換し
 「シートへ一括で転記する方法」 となります。
 
 配列内のデータをみると下記のように表示されております
 (データはダミーでス。データ量は全部で3000ほどあります)
 
─MyData
 ├MyData(0)
   ├MyData(0)(1)
   ├MyData(0)(1,1) aaa
     ├MyData(0)(1,2) bbb
     ├MyData(0)(1,3) ccc
 ├MyData(1)
   ├MyData(1)(1)
   ├MyData(1)(1,1) aaa
     ├MyData(1)(1,2) bbb
     ├MyData(1)(1,3) ccc
 ├MyData(3)
   ├MyData(3)(1)
   ├MyData(3)(1,1) aaa
     ├MyData(3)(1,2) bbb
     ├MyData(3)(1,3) ccc
 
 
 
 
 
(下記が実際のコードになります)
 
Sub 勤務_データ取込み()
    Dim mse As Integer: mse = MsgBox("フォルダ内の勤務実績を取込ます", vbYesNo, "勤務実績取込")
    If Not mse = vbYes Then
        MsgBox "キャンセル", vbOKOnly, "勤務実績取込"
        Exit Sub
    End If
    On Error GoTo Err_Loop
    Dim xlsApp As Application: Set xlsApp = Application
    With xlsApp
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
'-------------------------------------------------------------------------------
'【1】各種設定
'-------------------------------------------------------------------------------
    '▼カウンターなど
    Dim i As Long, r As Long, x As Long, y As Long, c As Long, str As String
    Dim Ws As Worksheet
    Dim flag As Boolean
    Dim Err_flag As Boolean '取込できなかった場合のフラグ
    Dim Err_msg As String '取込できなかったファイル名
    Dim PGbar As String: PGbar = "■"
    '▼ツール(WbA)を定義
    Dim WbA As Workbook: Set WbA = Application.ActiveWorkbook
    Dim WbA_sh1 As Worksheet: Set WbA_sh1 = WbA.Worksheets("割表exp")
    Dim WbA_sh2 As Worksheet: Set WbA_sh2 = WbA.Worksheets("マスタ")
    Dim InpSh_Name As String: InpSh_Name = WbA_sh2.Cells(2, 3) '参照元のシート名(年月)をマスタシートセル値から取得
    '割表expシートデータ範囲クリア
    r = WbA_sh1.Cells(Rows.Count, 2).End(xlUp).row
    If Not r = 1 Then WbA_sh1.Range("A2:AI" & r).Value = ""
    '処理月カレンダー設定
    '(未作成)
    '▼参照先(WbB)を定義
    Dim WbB As Workbook
    Dim WbB_InpSh As Worksheet '取込シート
    Dim BusyoName As String '部署名
    Dim BusyoData As String '実績データ入力値
    Dim v() As Variant '全勤務データ
    Dim vv As Variant '必要な勤務データ抽出
    Dim cData As Collection: Set cData = New Collection 'vvデータを順次格納
    '▼処理対象フォルダの定義:Tool自身=処理対象ファイルのあるフォルダパスを設定
    Dim FolderPath As String: FolderPath = xlsApp.ThisWorkbook.Path '自身のフォルダパス格納
    Dim FolderFile As String: FolderFile = Dir(FolderPath & "\勤務表*.xlsm") '検索値:ファイル名
'----------------------------------------------------------------------------
'【2】フォルダ内の取込む対象ファイル(WbB)を参照し処理(WbBデータをWbAへ転記)
'----------------------------------------------------------------------------
    Do While Not FolderFile = ""
        xlsApp.StatusBar = "[処理中...] " & FolderFile & " " & PGbar & "□" & "+++ "
        '▼転記BOOK元を開く(Book内の外部参照停止,読み取りで開く,読み取りメッセージ停止)
        Set WbB = xlsApp.Workbooks.Open(Filename:=FolderPath & "\" & FolderFile, _
                                        UpdateLinks:=False, ReadOnly:=True, Ignorereadonlyrecommended:=True)
        '取込シート名(yyymm)があれば以下格納
        For Each Ws In WbB.Worksheets
            If Ws.name = InpSh_Name Then
                flag = True
                Set WbB_InpSh = WbB.Worksheets(InpSh_Name) '取込シート名
                BusyoData = WbB_InpSh.Cells(8, 5) '実績データ入力値
                BusyoName = WbB.Worksheets("マスタ").Cells(1, 1) '部署名
                Exit For
            End If
        Next Ws
        '取込シートがない/実績未入力時→ファイル名格納しGoTo L1へスキップ
        If flag = False Or BusyoData = "" Then
            Err_flag = True
            Err_msg = Err_msg & FolderFile & vbCrLf
            GoTo SKIP_myLoop
        End If
'---------------------------------------------------------------------------
'【3】正常処理 指定シートがある場合 勤務表Dataを取り込み
'---------------------------------------------------------------------------
        '▼全データを一旦格納
        r = WbB_InpSh.Cells(Rows.Count, 3).End(xlUp).row + 1
        c = WbB_InpSh.Cells(4, 36).End(xlToLeft).Column
        v = WbB_InpSh.Range(WbB_InpSh.Cells(7, 2), WbB_InpSh.Cells(r, c)).Value '予定・実績行格納
        '▼抽出/勤務データ抽出
        ReDim vv(1 To 1, 1 To c) '一旦2次元配列をつくる
        x = 1
        For i = 1 To UBound(v, 1) Step 2 '個人2行に対し1行おきにデータ格納(要取込み行指定)
            '行数追加処理/初回:2次元配列に格納/2回目以降:1次元にバラして行追加
            If UBound(vv, 1) < x Then
                vv = Application.Transpose(vv) '1次元にバラす
                ReDim Preserve vv(1 To UBound(vv, 1), 1 To x) '行x追加して
                vv = Application.Transpose(vv) '2次元に戻す
            End If
            '2次元配列に格納
            vv(x, 1) = v(i, 1) 'ID(1行目)
            vv(x, 2) = v(i + 1, 1) '名前(2行目)
            vv(x, 3) = BusyoName '部署名(セル値)
            vv(x, 4) = v(i, 2) '職種=雇用形態(1行目)
            For y = 5 To c: vv(x, y) = v(i + 1, y - 1): Next y '勤務内容=実績(2行目)
            vv(x, 2) = Replace(vv(x, 2), " ", "") '空白除去
            vv(x, 2) = Replace(vv(x, 2), " ", "")
            x = x + 1
        Next i
        
'------------------------------------------------------------------------------
'【4】シート転記処理
'-----------------------------------------------------------------------------
        
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
'【現在はシートに逐一転記している状況】
        
'▼割表Expシート転記
        
' r = WbA_sh1.Cells(Rows.Count, 2).End(xlUp).row + 1 '転記起点行(rに対し±で範囲を調整)
' WbA_sh1.Range(WbA_sh1.Cells(r, 1), WbA_sh1.Cells(r - 1 + UBound(vv), c)) = vv

        
       ' ↓ ↓ ↓ ↓ ↓ ↓
       '
'@【今後はシートに逐一転記せずに配列に溜め込んで一気に転記したい】
        
'▼統合処理/上記データ取り込む都度にコレクションへ格納
        
         cData.Add vv

        
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
        '▼後処理(初期化)
        Erase v
        Erase vv '配列
        Set WbB_InpSh = Nothing '参照
SKIP_myLoop: '取込要件を満たさない部署はここに飛ぶ
        WbB.Close SaveChanges:=False '閉じる
        FolderFile = Dir() 'パス
        PGbar = PGbar + "■"
    Loop
     
Exit_Loop:
    Set WbB_InpSh = Nothing
    Set WbB = Nothing
    If Not xlsApp Is Nothing Then
        With xlsApp
            .StatusBar = False
            .EnableEvents = True
            .DisplayAlerts = True
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
    End If
    xlsApp.StatusBar = True
     
'----------------------------------------------------------------------
'【5】最終処理 シート転記・編集
'----------------------------------------------------------------------
     
'A【cData.Add vvを配列に変換し一気にシートへデータを転記したい】+++++++
    
    '▼統合データ配列に格納(COLLECTION→配列変換)
    Dim MyData As Variant 'COLLECTIONを配列に格納
    ReDim MyData(cData.Count - 1)
    i = LBound(MyData)
    Dim vTemp As Variant
    For Each vTemp In cData
        MyData(i) = vTemp
        i = i + 1
    Next vTemp
    
'上記データを一括でシートに転記-------★上記配列をシートに転記する方法が分からない^^;
     
    '※質問中---MyData をシートに転記※

    
     
    Stop
    
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
    
    '▼転記された個人の重複勤務データを1本化(重複値除去)しシート転記
    Call 重複者の勤務統合処理
 
    '▼取り込み除外ファイルがあればメッセージ
    If Err_flag = False Then
        MsgBox "正常に終了しました", vbOKOnly, "勤務実績取込"
    Else
        MsgBox "下記ファイルはシート又は、実績がないため" & vbCrLf & "取込みできませんでした" _
             & vbCrLf & vbCrLf & Err_msg, vbOKOnly, "エラー報告"
    End If
    Set xlsApp = Nothing
    Exit Sub
'---------------------------------------------------------------------
Err_Loop: 'エラー時:エラー番号・エラー種類
    MsgBox Err.Description, , Err.Number
    Resume Exit_Loop
End Sub

回答
投稿日時: 21/01/09 16:06:01
投稿者: simple

お疲れさまです。とりあえず第一感でのコメントをしておきます。
 
既に書いたと思いますが、
今のような二次元配列を要素に持つ一次元配列(*)を
そのままシートに書き出すことはできません。
あくまで、フラットな二次元配列でないと書き出せないと思います。
*こうしたものをジャグ配列と呼ぶことがあります。
 
どうしてもということなら、
いったん二次元配列に転記する作業が必要になりますね。
しかも要素毎に転記せざるを得ないので、少なくともその負荷は余分になります。
 
ものは試しなので、一度トライして結果を教えてください。

回答
投稿日時: 21/01/09 17:01:32
投稿者: Suzu

引用:
 ループ内で【3】で取り込んだデータを【4】で都度シートへ転記させておりますが
 多少の高速化とシートアクセスを減らしたく仕様変更しようと考えております。

 
コードを拝見させて頂いた中で、気になったのが
転記BOOK元となるファイル数が 10個
総データ数が 3000 (2行で1件分と考えると、6000行×y-1列) 分のデータでしょうか?)
 
との事ですが
 
・ファイルを開く/閉じるを繰り返す
    →そのファイル10個を順に開いて閉じて のみ を実行し
   どのくらいの時間を要しますでしょうか。
 
   全体の処理のうち、開く/閉じるで 大部分の時間を要していませんか?
   処理なしで、開く閉じるのみを繰り返してみてください。
 
・そのデータを配列に入れる段階で処理を行っている
  → 作業用シート等に全部コピーしてしまい、
   ワークシート関数にて必要なデータ形状に整形し 整形後のデータを
   本来のシートにコピペしたらどうでしょうか
 
・「コレクション」を使う必要性について疑問
  先にもご質問をさせて頂いておりますが、コレクション の必要性が確認できません。
  貼り付け時に、どうしても変換が必要になりますので、手間になるので速度的には不利になると思います。

回答
投稿日時: 21/01/09 17:15:54
投稿者: mattuwan44

>本コードのあるファイルと同じフォルダ内の「勤務表*.xlsm」とあるファイルが10コくらいあります。
 
1回と10回の書き込み時間の差は微々たるものだと思います。
試してみては?
 
>それを下記の順番で処理しております。

>'【1】各種設定
>'【2】フォルダ内の取込む対象ファイル(WbB)を参照し処理(WbBデータをWbAへ転記)
>'【3】正常処理 指定シートがある場合 勤務表Dataを取り込み
>'【4】シート転記処理 →(仕様変更中)COLLECTIONにデータを保留させる
>'【5】最終処理 →(仕様変更中)シート転記・編集

 
提示のコードは変数の数が多すぎて読む気になれなかったので、
こちらで日本語で説明されている部分で想像して書いてみました。
 

Option Explicit

'メイン
Sub test()
    Dim sFileList As Variant                     'データを読むファイルのフルパスの一覧
    Dim v As Variant                             '各フルパス
    
    '取り込むファイルのフルパス一覧の取得
    If GetFileList(ThisWorkbook.Path, sFileList) = False Then Exit Sub
    
    '各ファイルを順次処理
    For Each v In sFileList
        'データを加工してThisWorkbook.Worksheets(1)へ取り込む
        SetData ThisWorkbook.Worksheets(1), v
    Next
End Sub

'取り込むファイルのフルパス一覧を取得する関数
Function GetFileList(ByVal sFindPath As String, _
                     ByRef vFilePath As Variant) As Boolean
    Const cName As String = "\勤務表*.xlsm"
    Dim buf As String
    Dim vv() As Variant
    Dim i As Long
        
    ReDim vv(100)
    buf = Dir(sFindPath & sName)
    Do While Len(buf) > 0
        If ThisWorkbook.Name <> buf Then
            vv(i) = sFindPath & "\" & buf
            i = i + 1
        End If
    Loop
    If i > 0 Then
        ReDim Preserve vv(i - 1)
        GetFileList = True
    End If
End Function

'データを加工して取り込む
Sub SetData(ByRef wsh As Worksheet, _
            ByVal sFilePath As String)
    Dim v As Variant
    Dim c As Range
    Dim vData As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    
    With wsh
        Set c = .Cells(.rowscount, "A").End(xlUp).Offset(1)
    End With

    Set wb = Workbooks.Open(Filename:=vFilePath, ReadOnly:=True)
    On Error Resume Next
    Set ws = wb.Worksheets(ThisWorkbook.Worksheets(2).Cells(2, 3).Value)
    On Error GoTo 0
    If ws Is Nothing Then GoTo WayOut
        
    vData = GetData(ws)
        
    c.Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData

WayOut:
    wb.Close False
End Sub

'加工したデータの取得
Function GetData(ByRef ws As Worksheet) As Variant
    GetData = ws.UsedRange.Value
End Function

 
だいたい、このような流れになると思いますがいかがでしょうか?
処理時間よりもコードの読みやすさを重視しているつもりですが、
対象ファイルが10個程度なら違いはほぼ分からないかと。
こうやって分けておけば、
Function GetData
のプロシージャ内のみのデータの加工部分だけに集中して考えることが出来るかなと思います。
 
パット見、処理速度を改善できそうな部分は、
スペース文字の削除ですかね?
個々のデータでするより、
セル範囲で置き換え機能により取り除くと改善が見込めるかも?
データの加工部分は、元がどうなってて、どうしたいかが、
コードだけではわかりかねる部分があるので、よく読んでないです。
 
やりつくして不満なら、ファイルの開閉の部分から変更ですかね?
WinArrowさんが他の質問の回答でADOを薦められています。
他の方の質問等も参考にしてみては?

投稿日時: 21/01/10 00:51:11
投稿者: torao

皆様のアドバイスを元に作成しました。
 
(変更点)
 
・COLLECTIONの使用はやめました
 配列内にデータを保ったままデータを取得できました。
 ※ジャンク配列を調べましたがデータ抽出が難しそうなので断念。
 
・ダラダラ長いコードで可読性が悪い
 主要な処理部分はFunction化(今まで避けてきましたが勉強になりました)
 ※画面にコードがおさまりスクロールで上下しなくてよく、見やすくなりました。
 
(上記により)
 
・コードについて
 不要なコードを削ったりまとめたりしました。
 
・動作について
 「転記処理」「エラー発生時の処理」ともに動作確認できました。
 
・処理スピードについて
 「作業シート使用」「コード内で処理」ともに体感的に変わらないような気がしました。
 
※業務で使用はできそうですが
 気になる点は、単にみやすさだけで 「Function化」 してしまったような気がします。
 
 ご指摘がありましたら、アドバイスお願いいたします(^^) 
 
 
(変更後のコード)
 
Sub 勤務_データ取込み()
    Dim mse As Integer: mse = MsgBox("フォルダ内の勤務表実績を取込します", vbYesNo, "勤務実績取込")
    If Not mse = vbYes Then MsgBox "キャンセル", vbOKOnly, "勤務実績取込": Exit Sub
    On Error GoTo Err_Loop
    Dim xlsApp As Application: Set xlsApp = Application
    With xlsApp
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
'---------------------------------------------------------------------------------
'【1】各種設定
'---------------------------------------------------------------------------------
    '▼カウンターなど
    Dim flag As Boolean
    Dim Err_flag As Boolean '取込できなかった場合のフラグ
    Dim Err_msg As String '取込できなかったファイル
    Dim PGbar As String: PGbar = "■"
    '▼取込元(WbA)を定義
    Dim WbA As Workbook: Set WbA = Application.ActiveWorkbook
    Dim InpSh_Name As String: InpSh_Name = WbA.Worksheets("マスタ").Cells(2, 3) 'シート名(年月)を取得
    '▼参照先(WbB)を定義
    Dim WbB As Workbook
    Dim v() As Variant '全勤務データ
    Dim GetData As Variant '必要な勤務データ抽出
    Dim UB_row As Long 'vv配列追記用/最終行取得
    Dim GetFile_Cnt As Long 'vv配列追記用ファイル取込みカウント
    '▼処理対象フォルダの定義:Tool自身=処理対象ファイルのあるフォルダパスを設定
    Dim FolderPath As String: FolderPath = xlsApp.ThisWorkbook.Path '自身のフォルダパス格納
    Dim FolderFile As String: FolderFile = Dir(FolderPath & "\勤務表*.xlsm") '対象ファイル
'---------------------------------------------------------------------------------
'【2】フォルダ内の対象ファイル(WbB)を参照し勤務データを取り込む
'---------------------------------------------------------------------------------
    Do While Not FolderFile = ""
        xlsApp.StatusBar = "[処理中...] " & FolderFile & " " & PGbar & "□" & "+++ "
         
        Call GetFolderFile(FolderPath, FolderFile, WbB, InpSh_Name, v, flag, xlsApp) '元データ取込
         
        '取込シートがない/実績未入力時→ファイル名格納しGoTo L1へスキップ
        If flag = False Then
            Err_flag = True
            Err_msg = Err_msg & FolderFile & vbCrLf
            GoTo SKIP_myLoop
        End If
'---------------------------------------------------------------------------------
'【3】勤務データから必要な部分を抽出
'---------------------------------------------------------------------------------
        Call GetDataFromFolderFile(WbB, GetData, v, GetFile_Cnt, UB_row) 'データ抽出
        GetFile_Cnt = GetFile_Cnt + 1 'ファイル取り込み回数
 
SKIP_myLoop: '取込要件を満たさない部署はここに飛ぶ
        WbB.Close SaveChanges:=False '閉じる
        FolderFile = Dir() 'パス
        PGbar = PGbar + "■"
    Loop
     
Exit_Loop:
    Set WbB = Nothing
    If Not xlsApp Is Nothing Then
        With xlsApp
            .StatusBar = False
            .EnableEvents = True
            .DisplayAlerts = True
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
    End If
    xlsApp.StatusBar = True
     
'---------------------------------------------------------------------------------
'【4】【5】勤務データ重複除去/転記(複数部署の勤務表に名前がある場合データを1本化)
'---------------------------------------------------------------------------------
    '対象ファイルがまったくなかった場合はここでErrorになるので対処
    If Not GetFile_Cnt = 0 Then
        Call PasteTheGetData(GetData, WbA) 'データ加工と転記
    End If
    '▼取り込み除外ファイルがあればメッセージ
    If Err_flag = False Then
        MsgBox "正常に終了しました", vbOKOnly, "勤務実績取込"
    Else
   MsgBox "下記ファイルは、対象シート又は実績がないため" & vbCrLf &_
     "取り込みができませんでした" _
           & vbCrLf & vbCrLf & Err_msg, vbOKOnly, "エラー報告"
    End If
    Set xlsApp = Nothing
    Exit Sub
'---------------------------------------------------------------------------------
Err_Loop: 'エラー時:エラー番号・エラー種類
    MsgBox Err.Description, , Err.Number
    Resume Exit_Loop
End Sub
 
 
 
'---------------------------------------------------------------------------------
'【2】フォルダ内の対象ファイル(WbB)を参照し勤務データを取り込む
'---------------------------------------------------------------------------------
Function GetFolderFile(FolderPath As String, FolderFile As String, WbB As Workbook, InpSh_Name As String, _
                       v As Variant, flag As Boolean, xlsApp As Application)
    Dim ws As Worksheet
    Dim r As Long, c As Long
    '▼転記BOOK元を開く(Book内の外部参照停止,読み取りで開く,読み取りアラート)
    Set WbB = xlsApp.Workbooks.Open(Filename:=FolderPath & "\" & FolderFile, _
                                    UpdateLinks:=False, ReadOnly:=True, _
                  Ignorereadonlyrecommended:=True)
    '取込シート名/InpSh_Name(yyymm)があれば必要なデータ範囲格納
    For Each ws In WbB.Worksheets
        If ws.name = InpSh_Name Then
            flag = True
            With WbB.Worksheets(InpSh_Name)
                If .Cells(8, 5) = "" Then flag = False '特定セルに値がなければ除外する
                '全データを一旦格納
                r = .Cells(Rows.Count, 3).End(xlUp).row + 1
                c = .Cells(4, 36).End(xlToLeft).Column
                v = .Range(.Cells(7, 2), .Cells(r, c)).Value '予定・実績行全て格納
            End With
            Exit For
        End If
    Next ws
End Function
 
'---------------------------------------------------------------------------------
'【3】勤務データから必要な部分を抽出
'---------------------------------------------------------------------------------
Function GetDataFromFolderFile(WbB As Workbook, GetData As Variant, v As Variant, _
                               GetFile_Cnt As Long, UB_row As Long)
    '▼判定/データ初回取り込みか追記かをチェック
    Dim i As Long, x As Long, y As Long
    If GetFile_Cnt = 0 Then '初回のみ
        ReDim GetData(1 To 1, 1 To UBound(v, 2)): x = 1 '一旦2次元配列をつくる
    Else '2回目以降はvvを保持した状態で追記する
        x = UB_row + 1
    End If
    '▼抽出/勤務データ抽出
    For i = 1 To UBound(v, 1) Step 2 '個人2行に対し1行おきにデータ格納(要取り込み行指定)
        '行数追加処理/初回:2次元配列に格納/2回目以降:1次元にバラして行追加
        If UBound(GetData, 1) < x Then
            GetData = Application.Transpose(GetData) '1次元にバラす
            ReDim Preserve GetData(1 To UBound(GetData, 1), 1 To x) '行x追加して
            GetData = Application.Transpose(GetData) '2次元に戻す
        End If
        '2次元配列に格納
        GetData(x, 1) = v(i, 1) 'ID(1行目)
        GetData(x, 2) = v(i + 1, 1) '名前(2行目)
        GetData(x, 3) = WbB.Worksheets("マスタ").Cells(1, 1) '部署名
        GetData(x, 4) = v(i, 2) '職種=雇用形態(1行目)
        For y = 5 To UBound(v, 2)
            GetData(x, y) = v(i + 1, y - 1)
        Next y '勤務内容=実績(2行目)
        GetData(x, 2) = Replace(GetData(x, 2), " ", "") '空白除去
        GetData(x, 2) = Replace(GetData(x, 2), " ", "")
        x = x + 1
    Next i
    UB_row = UBound(GetData) 'vvデータ追記用の行数
    '▼後処理(初期化)
    Erase v
End Function
 
'---------------------------------------------------------------------------------
'【4】【5】勤務データ重複除去/転記(複数部署の勤務表に名前がある場合データを1本化)
'---------------------------------------------------------------------------------
Function PasteTheGetData(GetData As Variant, WbA As Workbook)
    Dim WbA_sh1 As Worksheet: Set WbA_sh1 = WbA.Worksheets("割表exp")
    Dim WbA_sh2 As Worksheet: Set WbA_sh2 = WbA.Worksheets("マスタ")
    '▼重複のない氏名リスト作成
    Dim i As Long, x As Long
    Dim ary() As Variant, ary2() As Variant
    x = -1
    For i = LBound(GetData) To UBound(GetData)
        x = x + 1
        ReDim Preserve ary(x)
        ary(x) = GetData(i, 2)
    Next i
    Dim dic As New Dictionary '重複除去処理
    For i = 0 To UBound(ary)
        If dic.Exists(ary(i)) = False Then dic.Add ary(i), ary(i)
    Next i
    ary2 = dic.Keys
    Set dic = Nothing
    '▼重複のない氏名リストを元に転記用データ作成
    Dim vList As Variant: ReDim vList(1 To UBound(ary2) + 1, 1 To UBound(GetData, 2))
    Dim y As Long, flag As Long
    '@名前の格納
    For i = 0 To UBound(ary2)
        vList(i + 1, 2) = ary2(i)
    Next i
    'A名前の照合と勤務データ転記(空の値に勤務データを転記する)
    '※1日の勤務先の勤務は重複しないので空欄を調べればデータ一本化が可能となる
    For i = 1 To UBound(GetData)
        For x = 1 To UBound(vList)
            If vList(x, 2) = GetData(i, 2) Then flag = 1: Exit For
        Next x
        If flag = 1 Then
            For y = 1 To UBound(vList, 2)
                If vList(x, y) = "" Then vList(x, y) = GetData(i, y)
            Next y
        End If
    Next i
    '▼シートへ転記
    With WbA_sh1
        .Range("A2:AI" & .Cells(Rows.Count, 2).End(xlUp).row).Value = ""
        .Range(.Cells(2, 1), .Cells(1 + UBound(vList), UBound(vList, 2))) = vList
    End With
    Erase GetData
    Erase vList
End Function
 
 

回答
投稿日時: 21/01/10 14:09:59
投稿者: simple

基本的には、下記のスレッドの継続ということなんですね。(今、気づきましたが)
「フォルダ内のbookを順次参照し処理で動作がもっさりしている」
https://www.moug.net/faq/viewtopic.php?t=79962
 
(1)
スピードアップが主たる動機であったとすると、
Timerを使って、どこで時間を要しているかの分析が重要でしょう。
・まず、処理をせずに開いて閉じるだけでどの程度掛かるのか、
・いくつかに処理を分けて、それぞれがどの程度掛かっているか
などの調査をまず、なさることが必要でしょう。
 
これもすでに指摘をいただいているところですが、
ExcelBookのOpen/Closeで相当部分が使われているものと想像されます。
ロジックを少々いじっても、大幅な改善は得られないことも想定されます。
スピードアップの限界を予め知ることことができますし、
それ以上に速度を上げたいというなら、
開く部分について、別手法を検討する切っ掛けにもなるでしょう。
既にいくつか別の手法も提案されています。
 
(2)どうしても一つの配列にまとめたい、ということだったのですから、
時間測定してもらえばよかったですね。
既に書きましたが、
その大きさを計算した上で、配列の大きさを宣言して、要素毎に転記すればよいでしょう。
どの程度速くなるのか(遅くなるのか)、実験してみたらよかったでしょう。
やっぱり時間が余計にかかってしまうよね、ということが判明すればそれはそれで成果でしょう。
ジャグ配列(ジャンクじゃないです)をもとに、二次元配列に展開するのは、基本的には
繰り返し処理で可能ですよね。何か難しいところがありますか?
 
(3)ざっと見ての感想です。
・どのようなくくりで関数プロシージャにするのか別の選択肢もあるかもしれませんね。
  少なくとも、WbBのopen,closeはmainに陽で書いた方が分かり易いという見方もあるかもしれません。
・関数プロシージャはすべての変数を値渡しする方法にされていますが、
  これもいろいろな方法があります。
  戻り値も使う方式にすれば、その関数の目的がより分かり易いかもしれません。
  また、モジュールレベル変数の一部併用も一考の余地があるかもしれません。
  まあこの辺は好みもありますから、絶対的なことは言えませんが。
・配列作成にあたって、その都度Transposeをしていますが、列を増やす処理を実行した後で、
  最後に一度だけTransposeする方法もあるでしょう。その方が速度的には有利だと思います。
・dictionaryの使い方がやや冗長に感ずるところもありますが、気のせいかも。
・xlsApp変数を何故使っているのか意図が不明でした。
  前回hatenaさんが指摘された方法(別のApplicationを使う方法)との混同なのでしょうか。
・概要を示すコメントが、コードの階層構造をかえって分かりにくくしている気がします。
でも、ご自分でここまで作成されているのはすばらしいと思いました。

投稿日時: 21/01/10 17:20:07
投稿者: torao

simple さん 詳しい説明ありがとうございます。
 
前回ご指導いただいた、ファイル操作については別処理で完成したので、それを応用させて新たに別ファイルで作成している途中でした。
 
とりあえず修正できた部分について
 

引用:
WbBのopen,closeはmainに陽で書いた方が分かり易い

・メインにOPEN・Closeで締めくくるように記載変更しました。確かに動きがわかりやすいです。
 
引用:
・配列作成にあたって、その都度Transposeをしていますが、列を増やす処理を実行した後で、
  最後に一度だけTransposeする方法もあるでしょう。その方が速度的には有利だと思います。

・予め追記させる人数を計算して「都度行処理」→「一括行追加」に変更しました。
 
'勤務データから必要な部分を抽出
Function GetDataFromFolderFile(WbB As Workbook, GetData As Variant, v As Variant, _
                               GetFile_Cnt As Long, UB_row As Long)
    '▼判定/データ初回取り込みか追記かをチェック
    Dim i As Long, x As Long, y As Long
    If GetFile_Cnt = 0 Then'初回のみ
    '一旦2次元配列をつくる
        ReDim GetData(1 To UBound(v) / 2, 1 To UBound(v, 2)): x = 1
    Else'2回目以降はvvを保持した状態で追記する
        x = UB_row + 1
        'GetDataに予めv格納行数を追加する処理
        'vデータの勤務表の個人数を特定する(個人行2段なので2で割りx+1の余分な行部-1)
        GetData = Application.Transpose(GetData) '1次元にバラす
    '行必要分追加
        ReDim Preserve GetData(1 To UBound(GetData, 1), 1 To x + (UBound(v) / 2) - 1)
        GetData = Application.Transpose(GetData) '2次元に戻す
    End If
    '▼抽出/勤務データ抽出
    For i = 1 To UBound(v, 1) Step 2'個人2行に対し1行おきにデータ格納(要取り込み行指定)
        GetData(x, 1) = v(i, 1) 'ID(1行目)
        GetData(x, 2) = v(i + 1, 1) '名前(2行目)
        GetData(x, 3) = WbB.Worksheets("マスタ").Cells(1, 1) '部署名
        GetData(x, 4) = v(i, 2) '職種=雇用形態(1行目)
        For y = 5 To UBound(v, 2)
            GetData(x, y) = v(i + 1, y - 1)
        Next y '勤務内容=実績(2行目)
        GetData(x, 2) = Replace(GetData(x, 2), " ", "") '名前空白除去(重複除去で使う)
        GetData(x, 2) = Replace(GetData(x, 2), " ", "")
        x = x + 1
    Next i
    UB_row = UBound(GetData) 'vvデータ追記用の行数
    '▼後処理(初期化)
    Erase v
End Function
 
引用:
・xlsApp変数について

・理解せず全部入りでお得的な感じで使用していました。
 どこまで必要か又は、変数に入れずに記載しても良いかなと思っております。
 
引用:
・dictionaryの使い方

・確かにダラダラ記載されてあるような感があります。
 今修正中です。
 
 

回答
投稿日時: 21/01/10 19:43:08
投稿者: simple

前回発言中で、「参照渡し」と書くべきところ、「値渡し」と誤記しています。訂正します。

回答
投稿日時: 21/01/12 08:00:01
投稿者: mattuwan44

読み込む規定のシートは、
7行目から、1行置きにデータを抜き出せばいいのですか?
で、何列目を見たら「重複」と判定するのでしょうか?
 

投稿日時: 21/01/12 20:53:06
投稿者: torao

mattuwan44 さま返信ありがとうございます。後ほどご報告致します。
 
simple さま 報告です。
 

引用:
・dictionaryの使い方

 
についてですが
 
 Dim ary() As Variant, ary2() As Variant
 
をなくしました。
 
ary・ary2経由せずに直接
 
GetData配列からdicにデータを格納し
dic.ItemsからvList配列にデータを取り込むようにしました。
 
無駄な処理がなくなって助かりましたありがとうございます。
 
Function PasteTheGetData(GetData As Variant, WbA As Workbook)
    Dim i As Long, x As Long, y As Long, flag As Long
    Dim dic As New Dictionary
    For i = LBound(GetData) To UBound(GetData)
        If dic.Exists(GetData(i, 1)) = False Then dic.Add GetData(i, 1), GetData(i, 1)
    Next i
    '▼重複のないIDリストを元に転記用データ作成
    Dim vList As Variant: ReDim vList(1 To dic.Count, 1 To UBound(GetData, 2))
    '@IDの格納
    Dim DItem As Variant
    i = 1
    For Each DItem In dic.Items
        vList(i, 1) = DItem: i = i + 1
    Next DItem
    Set dic = Nothing
 
(以下省略:変更なし)
   
 
 

回答
投稿日時: 21/01/12 21:44:54
投稿者: simple

お疲れさまです。
 
単に重複を除いたキーを作るなら、

    For i = LBound(GetData) To UBound(GetData)
        dic(GetData(i, 1)) = Empty
    Next i
と書くのが割と定番です。
 
別途質問されている回答によりますが、
itemとして、1からの連番を付せば、それがvListの行の整数インデックスに一致しますから、
それを援用すると、その後の処理で、vListと GetDataを再度マッチングする手間が省けるはずです。

回答
投稿日時: 21/01/13 10:46:20
投稿者: Suzu

・データの整形処理(配列変数間のやりとり含む)
・重複データの除外
を ファイル単位にて実施しているのが非効率と思います。
それらの処理は、転記後 に エクセルの機能(関数)を用いて処理できませんでしょうかね。
 
 
ここまでロジカルなコードを書いていらっしゃって、応答をなされているのに

引用:
ファイル操作については別処理で完成したので、それを応用させて新たに別ファイルで作成している途中でした。
の発言で 止めていらっしゃるのかがちょっと疑問です。
ネックと思われるファイル開閉の部分は 改善の余地はもう無い と確信されていると言う事なのでしょうか。
 
定量的に 処理時間がこのくらいで、この部分の速度向上の為に と言うのが良いと思いますよ。

投稿日時: 21/01/14 01:22:09
投稿者: torao

Suzu さま 気になりましたのでテストしてみました。
 

引用:
(PC)
HP ProBook 650GS
intelCorei5-8265U/1.60GHz-3.90GHz
RAM8.00GB
Windows10Pro-64bit
EXCEL2016-32bit
 
(フォルダ構成)
・デスクトップの作業フォルダ内に25個のファイル
・データを抽出する対象ファイル9個(エクセルファイルサイズ約700KB)
 
(9個のファイル開閉のみの処理時間) ※シート指定せずに単純に開閉のみ
 4.9400
 4.7180
 4.6740
 4.7550
 4.7070
平均 4.7588 ※0.5287(1ファイルあたり)
 
(1:配列のみ) ※全データを→@配列内で格納〜加工→Aシートに転記
 5.2580
 5.1020
 4.9780
 5.0089
 5.0349
平均 5.0763 ※0.31756(シート開閉除く)
 
(2:作業シート使用) ※全データを→@作業シートに転記→A配列内で加工→Bシート転記
 5.2409
 4.8649
 4.8829
 4.9841
 4.9589
平均 4.9863 ※0.22754(シート開閉除く)

 
結果: 全データをシートに転記して処理したほうが速い。
 
所見;
みなさんがアドバイスしていただいているように実際に数値にしてみると分かりました(多分)
 
データ処理はメチャクチャ速いように思えますし
ブックの開閉はPCスペック的に妥当とみて良いのかなと思えます。
今後、対象ファイルは増えたとしても20個以下ですので、逐一開いて閉じる方式でも良いと考えます。
 
テストファイル作成するのに勇気がいりましたを得ました。
 
 
 

投稿日時: 21/01/14 01:28:23
投稿者: torao

simple さま
 
早速アドバイスを元に下記のように変更したのですが
 
dic 内にデータがきちんと格納されているのに
 
dic.Itemsが vList内に転記できませんでした。
 
すみませんアドバイスをお願いします。
 
 
 
Function PasteTheGetData(GetData As Variant, WbA As Workbook)
    Dim i As Long, x As Long, y As Long, flag As Long
    Dim dic As New Dictionary
 
    For i = LBound(GetData) To UBound(GetData)
 
'下記の部分のコードを
 
        If dic.Exists(GetData(i, 1)) = False Then dic.Add GetData(i, 1), GetData(i, 1)
 
'下記に変更したのですが
    dic(GetData(i, 1)) = Empty
 
    Next i
 
    Dim vList As Variant: ReDim vList(1 To dic.Count, 1 To UBound(GetData, 2))
    Dim DItem As Variant
    i = 1
    For Each DItem In dic.Items
 
'vList内がからの状態でDitemが格納されない理由がわかりません
 
        vList(i, 1) = DItem: i = i + 1
 
 
    Next DItem
 

回答
投稿日時: 21/01/14 08:56:37
投稿者: simple

計測ご苦労様でした。
 
9ファイルの例で言えば、
5.1秒のうち94%にあたる4.8秒はFileの開閉に要する時間だったわけですね。
これだといくらファイル開閉以外の計算ロジックを工夫して、
仮にそれがゼロになったとしても、現在の94%にしかならないということですね。
速度をもっと上げようとすれば、ファイルの開き方から検討する必要があるということですね。
しかし、それを甘受し、標準的な方法と考えてそのまま使うという考え方もありえるでしょう。
 
後半の質問ですが、

dic("abc") = 100
としたとき、
  "abc"というkey と  100というItem
の対応関係が
dictionaryのなかに保存されるのです。
したがって、
For Each key In dic.Keys
    vList(i, 1) = key
    i = i + 1
Next
とすることになるでしょう。
 
ちなみに、ItemになぜEmptyなどというものを入れたかといえば、
それがdictionaryのitemの既定値だからです。
(Emptyは数値との演算では0として機能し、文字列との演算では""として機能します。)
また、値にEmptyを入れたということは、
重複排除したkeyしか使う積もりがないということを明確にするという意味もあると思います。
 
なお、dictionaryのitemに、Emptyではなく、連番を振っておけば、
それが、vListの行番号に一致しますから、
下記の繰り返しの中の前半部分は不要で、求めるxは、dic(GetData(i, 2))なわけです。
   For i = 1 To UBound(GetData)
        For x = 1 To UBound(vList)
            If vList(x, 2) = GetData(i, 2) Then flag = 1: Exit For
        Next x
        If flag = 1 Then
            For y = 1 To UBound(vList, 2)
                If vList(x, y) = "" Then vList(x, y) = GetData(i, y)
            Next y
        End If
    Next i 

回答
投稿日時: 21/01/14 10:40:58
投稿者: Suzu

テストありがとうございました。
 
確認ですが、
 
1:配列のみ
2:作業シート使用
 の シート開閉除く というのは、ファイルの開閉を含まない と言う事でしょうか?
 
メモリの使い方も変わるはずなので、ファイル開閉を含め 全時間 で比較して良いと思いますよ。
 
ファイル開閉を含めると 10秒程の処理でしょうか。
 
 
感想から言うと
 9ファイルの開閉が 5秒で終了 思ったほど時間を要していませんでした。
 手動で行うと 終わらない速度ですね。
 
 開閉が 9ファイルで、5秒、
 全データの処理時間 に 5秒
   手順が多いので、しょうがないのかもしれませんが、
   全データの処理時間に掛かっている気がします。
 
 
(2:作業シート使用) ※全データを→@作業シートに転記→A配列内で加工→Bシート転記
の『配列内で加工』は、
・2行データ→ 1行データへの加工
・データの重複除去
あたりでしょうか?
 
それぞれ
・2行データ→ 1行データへの加工
   → 作業列に、ワークシート関数を設置し、1行おきのデータに変形し、
     コピーし、値貼り付けを行い、関数から値に変更
     元の2行データ分の列を削除
         データの並べ替え または、オートフィルター を適用し空白行削除
 
・データの重複除去
  → データの統合 あたりで 処理できませんか?
 
そのあと、シート転記 で 処理時間の短縮ができそうな気がします。
 
 
あとは 私なら 全体 30秒以下 で済む処理であれば プログレスバーは表示させません。
画面更新の制御を行っているのに、わざわざ表示させる と言うのは「どうなんだろう」と思ってしまいます。

回答
投稿日時: 21/01/14 10:45:24
投稿者: simple

ああ、私はデータの読み方を間違っていたようですね。失礼。

投稿日時: 21/01/14 12:47:27
投稿者: torao

Suzu さん
   
・すみません書き方がまずかったようで
   
平均 4.9863・・・・全ての対象ファイルに対しブック開閉からシート転記までの合計タイムです。
   
※0.22754(シート開閉除く)・・・・上記平均からシート開閉処理のみを引いた数値です。
   
 
・プログレスバーについては、フォルダ内のファイル名を目視確認用として記述していましたが、思いの外処理が速いので、なくすかもしれません。
 
 
 
探究心で現在ファイルオープンについて
New Excel.Application
を調べていました。

回答
投稿日時: 21/01/14 14:27:24
投稿者: mattuwan44

シート上のイメージがわかりませんが。。。。
 

引用:
【3】勤務データから必要な部分を抽出
'---------------------------------------------------------------------------------
Function GetDataFromFolderFile

 
ここの部分エクセルの機能で十分対応可能では?
 
Option Explicit

'*******<シートを渡して別シートに指定の項目を抽出する関数>*********
'第一引数(wshFrom):元のデータがあるシート
'第二引数(wshTo):抽出したデータを書き込むシート
'第三引数(ixRow):データを書き込む先頭行番号
'返り値:作業が正常に行えたかのフラグ
'******************************************************************
Function Get加工データ( _
         ByRef wshFrom As Worksheet, _
         ByRef wshTo As Worksheet, _
         ByRef ixRow As Long)
    Dim rngData As Range
    Dim t
    
    t = Timer
    
    'シートのデータのチェック
    If IsEmpty(wsh.Cells(8, 5)) Then Exit Function
    
    'データのセル範囲を取得
    With wshFrom
        Set rngData = Application.Range(.Range("A7"), .UsedRange.Cells(.UsedRange.Cells.Count))
    End With
    
    '偶数行を削除とデータ内のスペース文字の除去
    Set rngData = Get奇数行(rngData)
    
    '結果書き込みシートへ転記
    rngData.Copy wshTo.Cells(ixRow, "A")
    '次の書き込み行番号を用意
    ixRow = ixRow + rngData.Rows.Count
    
    Debug.Print "データの加工", Timer - t
End Function

Function Get奇数行(ByRef Rng As Range) As Range
    'セル範囲を作業列分を拡張
    Set Rng = Rng.Resize(Rng.Columns.Count + 1)
    
    With Rng.Columns(Rng.Columns.Count)
        '作業列に目印を追加
        .Resize(2).Value = WorksheetFunction.Transpose(Array(1, ""))
        .Resize(2).AutoFill Destination:=.Cells
        '要らない行を削除
        Rng.Sort key1:=.Cells(1)
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    
    'セル範囲の再取得
    With Rng.Worksheet.UsedRange
        Set Rng = Application.Range(Rng(1), .Cells(.Columns.Count - 1, .Rows.Count))
    End With
    
    'スペース文字の削除
    With Rng
        .Replace " ", ""
        .Replace " ", ""
    End With
    
    Set Get奇数行 = Rng
End Function

 
こんな感じで書けばループがコード上で見えなくなります。
それで単純に高速化できてるかはわからないですけど、、、、
あとディクショナリーを使わなくても、重複の削除の機能はエクセルに備わっているので、
全部書き出した後、最後に1回したらいいかなと思いました。
もしかしたら、単純に重複の削除じゃないのかも知れませんが。。。
 
もしかして「統合」の機能で対応可能だったりして?

回答
投稿日時: 21/01/14 14:40:19
投稿者: Suzu

私もデータの見方を間違えた様ですね。
 
失礼しました。
 
 
ご質問の配列について、ひと段落であれば

引用:
探究心で現在ファイルオープンについて
New Excel.Application
を調べていました。

の疑問があるのであれば、スレッドも長くなりますので別スレッドにした方がよいでしょうね。

投稿日時: 21/01/16 21:36:10
投稿者: torao

皆様
 
長いこと色々とサンプルやアドバイス頂き感謝申し上げます。
 
最終的には、全て配列内で処理するのではなく、実際の処理時間を計測しセル転記後、配列処理という方式で落ち着きました。
 
まだ、ファイル作成は続いていますが、一旦ここで閉じさせていただき改めて質問をさせていただきます。