VBAでファイル名の取得と計算したデータの条件付き抽出

Question

既出かもしれませんがなかなか探し出せず、同じ質問でしたらすみません。
毎月フォルダ内にある８０前後のcsvファイルを処理しなければなりません。
各業者から提出された請求データを元に１つのファイルに集計しております。
VBAにて計算も同時に行い算出された値を各該当店舗へ貼り付けたいと思っております。

①フォルダ内のブック名は各業者の名前がついています。
②赤枠にそれぞれ開いたブックの名前をそのまま反映させたいです。
③青枠には各ファイルで計算した後の「店舗No」且つカテゴリ「商品」に合致する値を反映させたいです。今まではフィルタとVLOOKUPで行なっておりました。
※緑枠で囲った〔請求額－返品額－値引額〕の計算をさせてから出た値xのうちカテゴリ名「商品」だけを③の通りに反映させたい
④　①～③を繰り返してフォルダ内全てのデータを抽出したいです。

言葉足らずでしたら申し訳御座いません。

めぐみん_ · Accepted Answer

最初はダミーＢｏｏｋと２～３個のCSVファイルで検証してみて下さい。
尚、罫線や中央寄せ等は付けてません。
取り敢えずはご確認を。

Sub abc()
　　Dim objCn As Object
　　Dim objRS As Object
　　Dim FSO As Object
　　Dim Dic As Object
　　Dim strSQL As String
　　Dim F_path As String, F_col As Integer
　　Dim f, r As Range

Set Dic = CreateObject("Scripting.Dictionary")
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　Set objCn = CreateObject("ADODB.Connection")
　　Set objRS = CreateObject("ADODB.Recordset")

F_path = "G:\goo	est1" '◆ 実際のファイル保管フォルダを指定の事
　　F_col = 3

With objCn
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　.Properties("Extended Properties") = "Text;HDR=NO"
　　　　.Open F_path & ""
　　End With

With ActiveSheet

For Each r In .Range("A3", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　Dic.Add r.Value, r.Row
　　　　Next

For Each f In FSO.GetFolder(F_path).Files

If StrConv(FSO.GetExtensionName(f.Path), vbNarrow) = "csv" Then
　　　　　　　　.Cells(2, F_col).Value = FSO.GetBaseName(f.Path)

strSQL = ""
　　　　　　　　strSQL = strSQL & " SELECT F5,(F9-F10-F11)"
　　　　　　　　strSQL = strSQL & " FROM"
　　　　　　　　strSQL = strSQL & " [" & f.Name & "]"
　　　　　　　　strSQL = strSQL & " where ISNUMERIC(F5) AND F2 = '商品';"

Set objRS = objCn.Execute(strSQL)

Do Until objRS.EOF
　　　　　　　　　　.Cells(Dic(objRS(0).Value), F_col).Value = objRS(1).Value
　　　　　　　　　　objRS.MoveNext
　　　　　　　　Loop

F_col = F_col + 1
　　　　　　　　Set objRS = Nothing
　　　　　　End If
　　　　Next
　　End With

Set objCn = Nothing
　　Set FSO = Nothing
　　Set Dic = Nothing
End Sub

めぐみん_ · Answer

No.14です。

＞ただいくつかのファイルがデータ反映されていない為、Sheet構成・CSVファイルの列に違いがあるのか・・・

ここにつきましては、

strSQL = ""
　　　　　　　　strSQL = strSQL & " SELECT F5,(F9-F10-F11)"
　　　　　　　　strSQL = strSQL & " FROM"
　　　　　　　　strSQL = strSQL & " [" & f.Name & "]"
　　　　　　　　strSQL = strSQL & " where ISNUMERIC(F5) AND F2 = '商品';"

これはCSVファイルの左から５列目が数値になれる事且つ２列目が'商品'であるデータ群のうち、
５列目の値と計算結果を抽出するSQL文になってます。
なので仮に元がExcelBookでCSVファイルにして区切り文字をテキストエディタとかで消してしまったとか、
数値を全角数字で打ってるとかになるかな？
全角数字については集計Sheet側でも言えますね。全角数字で調べる（IF文）事になりかねないですし。
あとは"0"だからと空白にしてた場合なども。

その他については集計Sheetと一致しなかったファイルと店舗Noをイミディエイトウィンドウに書き出しておけば調べやすいかもですけど、
手間になりそうなら別Sheet（Sheetを指定して貰えれば）に書き出す事も可能とは思います。

めぐみん_ · Answer

でも、閉店している場合には、

＞000000000000100 0
＞こういった状態でした。

店舗Noの桁数が多くなるの？？？
確かに既存する店舗とは重複しないかもですが、出力結果とCSVファイルの中身には違いはなかったと思って宜しいのでしょうか？

めぐみん_ · Answer

No.12です。
お礼読みました。
その場合のケースは考えつかず申し訳ないです。

該当する付近のコードを

Do Until objRS.EOF
　　　　　　　　　　If Dic.Exists(objRS(0).Value) Then
　　　　　　　　　　　　.Cells(Dic(objRS(0).Value), F_col).Value = objRS(1).Value
　　　　　　　　　　Else '●
　　　　　　　　　　　　Debug.Print f.Nmae, objRS(0).Value '●
　　　　　　　　　　End If
　　　　　　　　　　objRS.MoveNext
　　　　　　　　Loop

このように変更して頂き、

・If文で集計Sheetの店舗Noに存在しているかどうかを判定し、存在していれば通常の処理をする。
・存在していない場合はイミディエイトウィンドウにファイル名と該当店舗Noを書き出す。
もし後者が不要であれば"●"の所は削除して下さい。

めぐみん_ · Answer

No.9のお礼について。

まず、

＞請求・返品・値引が全て０のところで止まってしまったと思われます。

についてはこちらでもデータを画像道理に準備してますので、全て０であるならSQL文での計算で０となり、結果０が表示されるのは確認してました。
なので

・実行する際には集計したいSheetがActiveな状態であること
・コードに『保存先のフォルダ』以外に修正した箇所があれば記載して欲しい
・集計及びCSVファイルの数値部分は半角数値であり、全角数字を使っていないか確認を
・少しは書き込めた（？）と言うのは、ファイル単位なのか行数単位なのか
⇒完全に読み込めたファイルがあったのか、或いは最初のファイルの途中で止まったのか。

Debug.Print objRS(0).Value, objRS(1).Value '◆追加
.Cells(Dic(objRS(0).Value), F_col).Value = objRS(1).Value
追加した行でイミディエイトウィンドウでは表示されるか、そこでエラー表示がでるか。

基本店舗Noの値にイレギュラーがあるか、若しくはCSVファイルのエンコードによるものかも知れません・・・・ってのも、最初からダメならわかるのですがね。
あとは画像と実際のSheet構成・CSVファイルの列などに違いがあるか。。。例えば書き込みを禁止しているとかセルの結合当たりかなど。
それでもエラー内容が違ってくるはずですが。。。

何回かCSVファイルのデータを弄って試しましたがその箇所でそのエラーがってのは起きないんですよね。

めぐみん_ · Answer

No.9です。

最後の方の

End With

Set objCn = Nothing
Set FSO = Nothing
Set Dic = Nothing

ここの所を

End With
  
  objCn.Close '◆追加
  Set objCn = Nothing
  Set FSO = Nothing
  Set Dic = Nothing

このように追加願います。

めぐみん_ · Answer

No.9です。

＞F_path = "G:\goo	est1" '◆ 実際のファイル保管フォルダを指定の事

これは

＜毎月フォルダ内にある８０前後のcsvファイル＞

この保管場所の事ですが検証時にはそのフォルダを指定して下さい。

programmermas999mac · Answer

②はfsoをつかって、次のようなコードでどうでしょうか
    Dim objFSO As Object
    Dim objFolder as Folder
    Dim objFile as File
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(目的のフォルダ")
    For each objFile in objFolder.Files
        if right(objfile.name,3) = "CSV" then
            (処理)
　　　　endif
    Next

③は、上のコードの処理の部分で、CSVとして開いたものをエクセルブックとして保存したうえで、ピボットテーブルを作成して、そこから値をコピーすればよいと思います。

④は上のコードのFor～Eachで実現出来てますよ。

めぐみん_ · Answer

No.3のお礼につきましてはわかりました。

No.4以降の検証をして頂きありがとうございます。
これならCSVを開かなくても作業できそうです。
あとは少々お時間を頂ければと思います。

めぐみん_ · Answer

度々すいません。

No.4の

Set objRS = New ADODB.Recordset

これは削除願います。

VBAでファイル名の取得と計算したデータの条件付き抽出

最初はダミーＢｏｏｋと２～３個のCSVファイルで検証してみて下さい。

No.14です。

でも、閉店している場合には、

No.12です。

No.9のお礼について。

No.9です。

No.9です。

②はfsoをつかって、次のようなコードでどうでしょうか

No.3のお礼につきましてはわかりました。

度々すいません。

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

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

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

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