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

総合ファイルに、C:\testフォルダ配下にあるxlsxファイルを読み込んで書き出すという内容をしたいのです。各ファイルに書かれているA,B列の内容を、総合ファイルのA,B列に書き出す。という処理をしたいのです。ただ、条件があります。添付ファイルに状況を書いたものを添付させていただきます。

<条件>
E列に書き込んであるファイル名のファイルは、総合ファイルに書き込まずスキップする。
という内容でプログラムを書きたいのです。

現在、分かっている状態としては、

不明①：E列の対象外ファイルに書かれているファイルリストを配列に入れる方法が不明。
解決②：Dirを使い、対象ファイルをすべてとりだす。
不明③：1と2をwhileでの二重ループを行い、一致しなかったものは、【新規書込み対象配列】に【ファイル名】を代入。
解決④：ループ完了後、新規書込み対象配列から、該当ファイルを取り出し、書き込み処理をする。

という流れになるのかなと思っているのですが、【2重ループの書き方】、【対象外リストファイルと一致しなかったときの新規配列(＝Writefile)】への代入方法がわからないのです。


■コード
With CreateObject("WScript.Shell")
.CurrentDirectory = "C:\test\"
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位になる可能性があるので、ループ処理が軽い物だと助かります。

よろしくお願いします。

質問者からの補足コメント

• 課題ではなくて、ただ複数のファイルを1つにまとめるのを手動でやるのがしんどくなってきているので、自分で書いたコードです。配列化する必要ないのですか。ちょっと再度考えてみます。

  No.3の回答に寄せられた補足コメントです。 補足日時：2022/01/06 22:46

• そうなんですね．①から③消去できるんですね。ありがとうございます。
  考えてきます。

  No.4の回答に寄せられた補足コメントです。 補足日時：2022/01/06 22:48

• [Open&Close の回数もどうなのかと気にはなりますが。]
  これについては、開いてコピーして、総合ファイルにペーストし、ペースト後はファイルを閉じるという処理をしています。
  
  ファイルを開かずにとりだす方法も考えてみることにします。

  No.5の回答に寄せられた補足コメントです。 補足日時：2022/01/06 22:50

• 

  ありがとうございました。何とか求める形になりました。
  たくさんの情報いただきありがとうございました。

    補足日時：2022/01/10 02:34

No.9 ベストアンサー 回答者： Qchan1962 回答日時： 2022/01/07 10:40

こんにちは

＞インデックスが有効範囲にありません。とエラー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の活用もありかも知れませんね

この回答へのお礼

ありがとうございます。１００４の配列エラーは、ファイル名が入っていないから、やはり起きてたんですね。エラー処理の書き方がわかっていませんでした。

参考にさせていただいて、コードを書いてみたんですが、「対象ファイルがありませんのエラーが表示され続けます。」

デバッグで変数の確認をしてみたりしてみたところ、filenameにはファイル名が入っているところまで確認できたのですが、どうも、
「If Application.CountIf(vfRng, Replace(Filename, ".xlsx", "")) = 0 Then」この部分で偽になって、真の時が入っていないようなのです。

ちょっと調べてみます。

お礼日時：2022/01/08 03:52

No.11 回答者： めぐみん_ 回答日時： 2022/01/08 10:49

実際のファイル名＋拡張子と If文の拡張子とセルに書き込んでいるファイル名について、全角半角・大文字小文字にミスがないかを調べてみるとか？

手入力での作業ですと入力の際に切り替わってなどあるかもですし。

No.10 回答者： めぐみん_ 回答日時： 2022/01/07 20:50

No.5です。

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

この回答へのお礼

ただいまエラー対応中ですが、Accessはインストールされているので大丈夫だったのかな。と思います。

お礼日時：2022/01/08 03:53

No.8 回答者： Qchan1962 回答日時： 2022/01/07 03:24

>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などで取得する事も可能ですが
就寝しますので課題にしておきます。あしからず。。

No.7 回答者： Qchan1962 回答日時： 2022/01/07 00:11

書き忘れました

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

この回答へのお礼

ありがとうございます。そうなんです。
こういう流れでやりたかったんです。

書いていただいたコードを実行したのですが、
実は、7行目がヘッダーで、8行目以降にデータがあるため8行目からデータを取り出そうとして


'8行目以降が対象
If n >= 8 Then SH.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(n - 3, 2).Value = .Range("A8:B" & n).Value
こんな感じで書き直してみたんですが、インデックスが有効範囲にありません。とエラーが出てしまいます。

4行目からではなく、8行目以降を対象とする場合どこを触ればいいでしょうか。


一度、追記したファイルは今後書き足さないようにするという処理は完璧でした。

お礼日時：2022/01/07 02:53

No.6 回答者： Qchan1962 回答日時： 2022/01/07 00:03

こんばんは

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

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

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:\test\"
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

No.5 回答者： めぐみん_ 回答日時： 2022/01/06 11:51

No.3です。

該当しなければスルーして下さい。

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

この回答へのお礼

あれから試してみたところ、ひとまず自分で書いたもので、追記したファイル処理なしで動きました。ありがとうございます。

お礼日時：2022/01/07 02:54

No.4 回答者： 初心者ですが何か。 回答日時： 2022/01/06 09:32

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

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

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

この回答へのお礼

あれから試してみたところ、ひとまず自分で書いたもので、追記したファイル処理なしで動きました。ありがとうございます。

お礼日時：2022/01/07 02:54

No.3 回答者： めぐみん_ 回答日時： 2022/01/06 08:35

これって課題ですか？

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

No.2 回答者： mygoonickname 回答日時： 2022/01/06 08:03

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

この回答へのお礼

ありがとうございます。今から試させていただきます。

お礼日時：2022/01/06 22:45