エクセルVBAの配列二重ループ処理コードの書き方につきまして。

Question

総合ファイルに、C: estフォルダ配下にあるxlsxファイルを読み込んで書き出すという内容をしたいのです。各ファイルに書かれているA,B列の内容を、総合ファイルのA,B列に書き出す。という処理をしたいのです。ただ、条件があります。添付ファイルに状況を書いたものを添付させていただきます。 <条件> E列に書き込んであるファイル名のファイルは、総合ファイルに書き込まずスキップする。という内容でプログラムを書きたいのです。現在、分かっている状態としては、不明①：E列の対象外ファイルに書かれているファイルリストを配列に入れる方法が不明。解決②：Dirを使い、対象ファイルをすべてとりだす。不明③：1と2をwhileでの二重ループを行い、一致しなかったものは、【新規書込み対象配列】に【ファイル名】を代入。解決④：ループ完了後、新規書込み対象配列から、該当ファイルを取り出し、書き込み処理をする。という流れになるのかなと思っているのですが、【2重ループの書き方】、【対象外リストファイルと一致しなかったときの新規配列(＝Writefile)】への代入方法がわからないのです。 ■コード With CreateObject("WScript.Shell") .CurrentDirectory = "C: est" End With 不明① BaseStartrow = 4 BaseEndrow = Cells(Rows.Count, 5).End(xlUp).Row '最終行を取得 '配列への書込み方法がわからないfile1とfile3を対象外配列に書き込みたい。【コード不明】 ②対象フォルダ内のファイルを取り出す。 Filename = Dir("*.xlsx") ③①と②の配列から値を取り出し、一致したら書き出し対象配列(=配列名Writefileと一応します)に、ファイル名(中身)を代入する Do While Filename <> "" 【コード不明】 loop ④ Do While Writefile <> "" 【コード解決済み】 loop お分かりの方がおられましたら、ご教示お願いします。後、説明のために、簡単にしているのですが、一度書き込んだファイルは、E列の末尾にファイル名を追記する。という処理をしているので最終的にリストは200位になる可能性があるので、ループ処理が軽い物だと助かります。よろしくお願いします。

Qchan1962 · Accepted Answer

こんにちは
＞インデックスが有効範囲にありません。とエラー1004
まだエラー処理を付け加える必要があるように思います
この辺は、ご質問と離れてしまいますしデバッグに関する事で
仕様や環境を精査しなくては成らない部分かと思います。。

エラー1004で気が付いた点だけ付け加えると
Doで対象ファイル名を配列に入れる処理の後、対象ファイルが無かった（取得できなかった）時にUBound(trgAry)で1004が発生します
その対策としてtrgAry配列のインデックスに使用したnの値は
ファイル名取得後　n = n + 1　されるので　0の時で対応出来そうかな？

Loop
If n = 0 Then MsgBox ("新規抽出対象ファイルがありません"): Exit Sub
    For i = 0 To UBound(trgAry)

他の方法としては
エラーをトリガーに指定ラベルに飛ばし終了
    Loop
    On Error GoTo NothingFile
    For i = 0 To UBound(trgAry)
・
・
    Exit Sub
NothingFile:
    MsgBox ("新規抽出対象ファイルがありません")
End Sub
などが考えられますね

昨晩の回答を含め
   Loop
    If n = 0 Then MsgBox ("新規抽出対象ファイルがありません"): Exit Sub
    Application.ScreenUpdating = False
    For i = 0 To UBound(trgAry)
        With Workbooks.Open(folPath & trgAry(i))
            With .Worksheets(1)
                n = .Cells(Rows.Count, "A").End(xlUp).Row
    '8行目以降が対象
                If n >= 8 Then
                    SH.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(.Range("A8:A" & n).Count, 2).Value _
                            = .Range("A8:B" & n).Value
                End If
            End With
            .Close SaveChanges:=False
        End With
    Next
    '処理ファイル名を追加
    With SH.Cells(Rows.Count, "E").End(xlUp).Offset(1).Resize(UBound(trgAry) + 1)
        .Value = Application.Transpose(trgAry)
        .Replace What:=".xlsx", Replacement:=""
    End With
    Application.ScreenUpdating = True
End Sub

左辺の基軸セルを指定したのちサイズ変更を行う場合は
左辺のResize時に右辺のサイズでResizeする、、

余：
開くファイルが多く、取得セルが少くなく且つ限定範囲なら
ExecuteExcel4Macroの活用もありかも知れませんね

mygoonickname · Answer

おはようございます。

一部になりますが、手書きなので、もしエラーになった場合はすみません
が、適宜修正をお願いします。

セル範囲を配列に入れる方法の例　myDatに2次元配列で入ります。

Dim myDat As Variant, I As Long, J As Long, myFlag As Boolen
myDat = Range(Range("E4"),Cells(Rows.Count, 5).End(xlUp)).Value

データが幾つかは、Uboundで取得が可能です。
きっと、配列名Writefileとの2重ループになるかと思いますが。
Writefileは、1次元配列でしょうか？

For J=Lbound(Writefile) to Ubound(Writefile)
myFlag=False
For I=1 to Ubound(myDat)
If myDat(I,1) = Writefile(J) Then 
myFlag = True
End If
IF myFlag Then
’一致した場合の処理　書き出し？
End If
Next I

mygoonickname · Answer

No.1の者です。

一致なのか、一致しなかった場合かが、良く分からなかったので。
すみません、途中で混乱してしまいました。

配列に入れる方法は、すみませんが、下記で調べてみて下さい。
配列の上限を増やす方法で、Preserveを指定すると、配列の中身を保持
したまま、上限数を増やせます。

ReDim Preserve

＞③①と②の配列から値を取り出し、一致したら書き出し対象配列(=配列名Writefileと一応します)に、ファイル名(中身)を代入する
→　一致した場合
＞E列に書き込んであるファイル名のファイルは、総合ファイルに書き込まずスキップする。
→　一致しなかった場合？

●一致の場合は、随時配列に書き込み
Dim myDat As Variant, I As Long, J As Long, 
myDat = Range(Range("E4"),Cells(Rows.Count, 5).End(xlUp)).Value

For J=Lbound(Writefile) to Ubound(Writefile)
myFlag=False
For I=1 to Ubound(myDat)
If myDat(I,1) = Writefile(J) Then
’一致が見付かったので、ここで配列に書き込みで良いかと

End If
Next I

●一致しなかった場合は、判定してから書き込み
Dim myDat As Variant, I As Long, J As Long, myFlag As Boolen
myDat = Range(Range("E4"),Cells(Rows.Count, 5).End(xlUp)).Value

データが幾つかは、Uboundで取得が可能です。
きっと、配列名Writefileとの2重ループになるかと思いますが。
Writefileは、1次元配列でしょうか？

For J=Lbound(Writefile) to Ubound(Writefile)
myFlag=False
For I=1 to Ubound(myDat)
If myDat(I,1) = Writefile(J) Then
myFlag = True
End If
IF myFlag = False Then
’一致しなかった場合の処理　書き出し
End If
Next I

めぐみん_ · Answer

これって課題ですか？

Ｅ列にある除外対象を配列化する必要もないと思うのですが、それを前提とするので気になりましたが。

初心者ですが何か。 · Answer

私も気になる（以前にもですが）けど。

VBAでも使える数式（ワークシート関数）はありますので、今回Ｅ列に該当するファイルってならCountIf関数で０か否かで済みそうな気もしますけど？
わざわざ存在を調べる為だけにループを掛けなくても。
ただし片方は拡張子ありで片方はなし。
ここの処理をちゃんとしないと全てスル～されてしまいますけどね。

これで不明の①～③（前半）は消去できる。
ただ③（後半）と④については、何を言っているのか全く説明がない。

めぐみん_ · Answer

No.3です。
該当しなければスルーして下さい。

これってＥ列に当てはまらないファイルからデータを収集するのですよね？
配列化もいいのですがどれだけBookが存在するかによっては、Open&Close の回数もどうなのかと気にはなりますが。
Excelアプリで開かずにデータを取り出す手段も検討されてみては？

Qchan1962 · Answer

こんばんは
横から失礼します。
もう少しシンプルなロジックでも良いように思うのですが・・
ご質問の流れで想像の範疇もありますが、全体を通すとこんな感じでしょうか？

配列に入れ付き合わせも良いのですが、＃４様が指摘している方法の方が
判りやすいのではないかと思います。

Sub Sample()
Dim i As Long, n As Long
Dim folPath As String, Filename As String
Dim vfRng As Range, trgAry()
Dim SH As Worksheet
    Set SH = ActiveSheet
    Set vfRng = SH.Range("E4", SH.Cells(Rows.Count, "E").End(xlUp))
    folPath = "C:	est"
    Filename = Dir(folPath & "*.xlsx")

'②と③を同時に
    Do While Filename <> ""
        If Application.CountIf(vfRng, Replace(Filename, ".xlsx", "")) = 0 Then
            ReDim Preserve trgAry(n)
            trgAry(n) = Filename
            n = n + 1
        End If
        Filename = Dir
    Loop

For i = 0 To UBound(trgAry)
        With Workbooks.Open(folPath & trgAry(i))
            With Worksheets(1)
                n = .Cells(Rows.Count, "A").End(xlUp).Row
    '4行目以降が対象
                If n >= 4 Then SH.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(n - 3, 2).Value = .Range("A4:B" & n).Value
            End With
            .Close SaveChanges:=False
        End With
    Next
    
    '処理ファイル名を追加
    With SH.Cells(Rows.Count, "E").End(xlUp).Offset(1).Resize(UBound(trgAry) + 1)
        .Value = Application.Transpose(trgAry)
        .Replace What:=".xlsx", Replacement:=""
    End With

End Sub

Qchan1962 · Answer

書き忘れました
With Worksheets(1)はWith .Worksheets(1)に訂正してください
無くてもActiveWorkbookが省略されていますので動きますが、一応。
また、Worksheets(1)は対象ファイルの該当シートを指定してください。
共通でない場合は更にシート名の配列もしくはコレクションを作成する必要があります。

Qchan1962 · Answer

>If n >= 8 Then SH.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(n - 3, 2).Value

.value=.valueは右辺と左辺の大きさ（セルの数）を同じにしなくてはいけません。

n = .Cells(Rows.Count, "A").End(xlUp).Row
ｎは、最終行ナンバーを取得しますので
範囲サイズを変更する.Resizeの部分で対象範囲外の上部行数を引く必要があります。つまり、n - 3　ここです

この辺りの定数はcells.countなどで取得する事も可能ですが
就寝しますので課題にしておきます。あしからず。。

めぐみん_ · Answer

No.5です。

一応ひと段落ついたと見なして宜しいのでしょうか？
ちなみに先の回答ではAccessもインストールされているのが条件ではありました。

エクセルVBAの配列二重ループ処理コードの書き方につきまして。

おはようございます。

No.1の者です。

これって課題ですか？

私も気になる（以前にもですが）けど。

No.3です。

こんばんは

書き忘れました

>If n >= 8 Then SH.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(n - 3, 2).Value

こんにちは

No.5です。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング