[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『サブフォルダを含んでいるCSVの統合』（はる）
いつもお世話になっております。
ひとつのフォルダを選び、その中の全てのCSVファイル（サブフォルダも含みます）を統合して、新規のエクセル（.ｘｌｓｘ）で保存させたいのです。
ただ、ひとつのキーワードとなる言葉が、ＣＳＶの1行の中に入ってたら、その行は結合しないという規則があります。
その行が何行あるのか、何行目にあるのかが、データによって違うのです。
また、キーワードも、処理するひとつのフォルダ（サブフォルダも含みます）によって変わります。（キーワードがないときもあります）
ご教授のほど、回答をよろしくお願い申し上げます。
＜ 使用 Excel：Excel2007、使用 OS：Windows8 ＞
１．統合先の新規ブックを作成します
２．指定フォルダ（含むサブフォルダ）の中からＣＶＳファイル名を抽出します。
３．抽出したＣＳＶファイル名ごとに
１）そのＣＳＶファイルをブックとして開きます
２）そのブックとして開かれたＣＳＶファイルにシートの1行目から最終行までをループで取り出します。
３）その行の中に、指定のキーワードがあれば除外、なければ、それを統合先の新規ブックのシートに順々に書きこんでいきます
４）最後の行までの処理が終われば、このＣＳＶファイルを閉じます
４．次のＣＳＶファイルに対して３．の処理を繰り返して行います
５．新規ブックとして生成した、ＣＳＶファイルが統合されたブックを、名前を付けてしかるべきフォルダに保存します。
この中のどの部分の回答を期待していますか？
すべて？
１．と ３．－１）と ３．－４）と ５． については、エクセル上で操作してマクロ記録をとればコードが入手できますから
それ以外のところですかね？ それ以外のところでも、すでに はる さんの知識でＯＫのところもあると思います。
それらを除いた部分、、わからないところを、教えてください。
そうすれば、皆さんからアドバイスがあると思います。
それとも、丸々、お願いということですか？
（β） 2016/02/22(月) 19:56
フォルダを選択したところから、サブフォルダまで行って、その中のファイルを開くところから、すでにわかりません。。。
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
任意のフォルダにあるファイルをエクセルに書き出す
Sub SampleFoldDir()
Dim Folder1 As String, FileA As String, LastRow As Long
'フォルダを任意で選択する
With Application.FileDialog(msoFileDialogFolderPicker).Show
Folder1 = .SelectedItems(1)
End With
'選んだフォルダの拡張子xlsを含むファイルを返す
FileA = Dir(Folder1 & "\*.csv")
'フォルダ内のファイルがなくなるまで繰り返す
Do While FileA <> ""
'Dirのpathnameの指定をなくす
FileA = Dir()
Loop
End Sub
：：：：：：：：：：：：：：：：：：：：：：：：
新規ブックの作成保存
Sub workbookSaveAs02()
'ローカル変数宣言
Dim objWorkbook As Workbook
'新規ブックを作成し、変数に格納
Set objWorkbook = Workbooks.Add
'新規ブックのファイル名を「Book2.xls」にして
'C:\Users\Masaki\Documents以下に保存
objWorkbook.SaveAs Filename:="C:\Users\Masaki\Documents\Book2.xls", _
FileFormat:=xlWorkbookNormal
End Sub
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
あるフォルダの中に存在するすべてのサブフォルダを調べる
Sub Test()
Dim cnt As Long
cnt = 0
Call Sample3("C:\Work")
End Sub
Sub Sample3(Path As String)
Dim buf As String, f As Object
buf = Dir(Path & "\*.*")
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
buf = Dir()
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(Path).SubFolders
Call Sample3(f.Path)
Next f
End With
End Sub
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
CSVファイルの読み込み
Sub CSV_Read2()
Dim FileType, Prompt As String
Dim FileNamePath As Variant
Dim textline, csvline() As String
Dim Rowcnt, ColumNum As Integer
Dim ch1 As Long
FileType = "CSV ﾌｧｲﾙ (*.csv),*.csv"
Prompt = "CSV File を選択してください"
'操作したいファイルのパスを取得します
FileNamePath = SelectFileNamePath(FileType, Prompt)
If FileNamePath = False Then 'キャンセルボタンが押された
End
End If
'空いているファイル番号を取得します
ch1 = FreeFile
'FileNamePath のファイルをオープンします
Open FileNamePath For Input As #ch1
'エラーが発生したらファイルを閉じます
'CSVのファイルは1行の項目数が正確に合っていないと読めないのですが、
'色々なCSVがあるようなので入れておきます
On Error GoTo CloseFile
'表の行番号の初期化 1行目から読み込んだデータを入力します
Rowcnt = 1
Do While Not EOF(ch1) 'ファイルの終端かどうかを確認します。
'1行読み込みます
Line Input #ch1, textline
'ダブルクォーテーションを削除します
'カンマ+ダブルクォーテーションで区切られている CSVファイル
'などは適時追加してください
textline = Replace(textline, """", "")
'カンマで分離します
csvline() = Split(textline, ",")
'配列渡しでセルに代入
Range(Cells(Rowcnt, 1), _
Cells(Rowcnt, UBound(csvline()) + 1)) = csvline()
Rowcnt = Rowcnt + 1
Loop
CloseFile:
'ファイルを閉じます
Close #ch1
End Sub
（はる） 2016/02/23(火) 00:46
Function SelectFileNamePath(FileType, Prompt) As Variant
SelectFileNamePath = Application.GetOpenFilename(FileType, , Prompt)
End Function
（はる） 2016/02/23(火) 01:07
Sub test2()
Dim FolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then 'アクションボタンがクリックされた
FolderPath = .SelectedItems(1)
Else 'キャンセルボタンがクリックされた
FolderPath = ""
End If
End With
'ローカル変数宣言
Dim objWorkbook As Workbook
'新規ブックを作成し、変数に格納
Set objWorkbook = Workbooks.Add
Call Sample3(FolderPath)
End Sub
Sub Sample3(FolderPath As String)
Dim cnt As Long
cnt = 0
Dim ch1, r As Long
Dim buf As String, f As Object
buf = Dir(FolderPath & "\*.*")
Do While buf <> ""
cnt = cnt + 1
' Cells(cnt, 1) = buf
buf = Dir()
Debug.Print FolderPath & "\" & buf
Dim FileNamePath As Variant
Dim textline, csvline() As String
Dim Rowcnt, ColumNum As Integer
'操作したいファイルのパスを取得します
If InStr(buf, ".csv") > 0 Then
FileNamePath = FolderPath & "\" & buf
'空いているファイル番号を取得します
ch1 = FreeFile
'FileNamePath のファイルをオープンします
Open FileNamePath For Input As #ch1
'エラーが発生したらファイルを閉じます
'CSVのファイルは1行の項目数が正確に合っていないと読めないのですが、
'色々なCSVがあるようなので入れておきます
On Error GoTo CloseFile
'表の行番号の初期化 1行目から読み込んだデータを入力します
Rowcnt = 1
Do While Not EOF(ch1) 'ファイルの終端かどうかを確認します。
'1行読み込みます
Line Input #ch1, textline
'ダブルクォーテーションを削除します
'カンマ+ダブルクォーテーションで区切られている CSVファイル
'などは適時追加してください
textline = Replace(textline, """", "")
'カンマで分離します
csvline() = Split(textline, ",")
'配列渡しでセルに代入
Range(Cells(r + 1, 1), _
Cells(r + 1, UBound(csvline()) + 1)) = csvline()
r = r + 1
Rowcnt = Rowcnt + 1
Loop
CloseFile:
'ファイルを閉じます
Close #ch1
End If
Loop
With CreateObject("Scripting.FileSystemObject")
For Each f In .GetFolder(FolderPath).Subfolders
Call Sample3(f.Path)
Next f
End With
End Sub （はる） 2016/02/23(火) 03:43
ずいぶん頑張られましたね！ 敬服です。 もう少し、部品だけ、マクロ記録で生成し、ループ処理はギブアップやむなしかな？ と思ったんですが。
作り上げられたコード部品をなるべく生かして、コードを書いてみます。（ＦＳＯを使っておられますのでフォルダ選択以外はＦＳＯで書いてみようと思っています）
午後になるかと思います。それまでに、他の回答者さんから回答があればいいですね。
（β） 2016/02/23(火) 09:59
以下の３点、教えてください。
１．キーワードは、完全一致ですか、部分一致ですか？ ２．キーワードが現れる列は固定されていますか（Ｂ列とか、Ｃ列とか） あるいはどの列にあるかわからないのですか？ ３．ＣＳＶファイルの1行目はタイトル行ですか？それとも1行目からデータですか？
（β） 2016/02/23(火) 11:54
一応書いてみました。
・できるだけ はるさんが調べられた FSO を中心に記述しました。FSO は、フォルダからの取り出しが【非常に遅い】です。 早さを求めるなら DIRコマンドや あるいは API を使う方法もありますが、わかりやすさという点もあり FSOを選びました。 ・CSVファイルの実際の取り出しは、エクセルブックとして開く方法をとっています。これも【非常に遅い】です。 速さを求めるなら メモリー内ですべて読みこみ、正規表現などで除外文字列のある行を削除し、それをテキストファイルあたりに書きだしながら さいごに新規ブックにそのテキストファイルを取り込むということも考えられますが、これも、わかりやすさ で。
どうしようもなく遅いということなら、手を入れてもいいですが、もしかしたら上級者さんたちからのコードアップもあるかもしれませんので 期待して待ちましょう。
なお、CSVファイルの1行目がタイトル行、除外文字が存在する列は不特定、マッチングは部分一致にしてあります。 ここも、列が決まっていればフィルター機能を使い、もう少し早い処理に変更できます。
Sub Sample()
Dim pPath As String
Dim pFold As Object
Dim ignore As String
Dim fso As Object
Dim fPool As Variant
Dim dic As Object
Dim fPath As Variant
Dim shT As Worksheet
Dim shF As Worksheet
Dim done As Boolean
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
pPath = .SelectedItems(1)
End With
'除外文字列指定
ignore = Application.InputBox("除外文字列を指定してください。もし、除外文字列がない場合は" & vbLf & _
"このままＯＫボタン、あるいはキャンセルボタンを押してください", Type:=2)
'フォルダからのCSVファイル抽出(含むサブフォルダ）
Set pFold = fso.GetFolder(pPath)
GetFiles pFold, dic
If dic.Count = 0 Then
MsgBox "ファイルがありません"
Exit Sub
End If
'統合用新規ブックの作成(シートは1枚のみ）
Set shT = Workbooks.Add(xlWBATWorksheet).Sheets(1)
'抽出したCSVファイルの取り出し
For Each fPath In dic
Set shF = Workbooks.Open(fPath).Sheets(1)
CutData shF, ignore
If Not done Then
shF.Cells.Copy shT.Range("A1")
done = True
Else
shF.Range("A1", shF.UsedRange).Offset(1).Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
shF.Parent.Close False
Next
'新規ブックを保存。同名のものがあれば無条件上書き。
Application.DisplayAlerts = False
shT.Parent.SaveAs Filename:=ThisWorkbook.Path & "\新しいブック名.xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Application.Goto shT.Range("A1")
Application.ScreenUpdating = True
MsgBox "統合完了"
End Sub
'FSO 再帰処理でフォルダ内のCSVファイルを抽出
Private Sub GetFiles(pFold As Object, dic As Object)
Dim myFile As Object
Dim myFolder As Object
'ファイル名を列挙
For Each myFile In pFold.Files
If LCase(Right(myFile.Path, 4)) = ".csv" Then dic(myFile.Path) = True
Next myFile
'サブフォルダを検索
For Each myFolder In pFold.subfolders
Call GetFiles(myFolder, dic)
Next myFolder
End Sub
'除外文字列の処理
Private Sub CutData(sh As Worksheet, ignore As String)
Dim c As Range
Dim f As Range
Dim r As Range
If ignore = "" Then Exit Sub
Set c = sh.UsedRange.Find(What:=ignore, LookAt:=xlPart)
If c Is Nothing Then Exit Sub
Set f = c
Do
If r Is Nothing Then
Set r = c.EntireRow
Else
Set r = Union(r, c.EntireRow)
End If
Set c = sh.UsedRange.FindNext(c)
Loop While c.Address <> f.Address
r.Delete
End Sub
（β） 2016/02/23(火) 17:56
↑
ignore = Application.InputBox("除外文字列を指定してください。もし、除外文字列がない場合は" & vbLf & _
"このままＯＫボタン、あるいはキャンセルボタンを押してください", Type:=2)
これを
ignore = Application.InputBox("除外文字列を指定してください。" & vbLf & _
"もし除外文字列がない場合はこのままＯＫボタンを押してください", Type:=2)
If ignore = "False" Then Exit Sub 'キャンセルボタン
に変更してください。
（β） 2016/02/23(火) 20:00
１．キーワードは、完全一致ですか、部分一致ですか？
完全一致です。（キーワードがない時もあります）
２．キーワードが現れる列は固定されていますか（Ｂ列とか、Ｃ列とか） あるいはどの列にあるかわからないのですか？
A列になります。
３．ＣＳＶファイルの1行目はタイトル行ですか？それとも1行目からデータですか？
1行目は、どちらの場合もあります。
FSOは、非常に遅い。。。だったんですね。そんなことも知り得ませんでした。
DIRというのがコードの中に入っているものでも何度も試してみたのですが、
ステップインで確かめるたびにファイル名などが行ったり来たりするようなものしか作れず、頭が混乱してしまいました。
早速今夜、β様のコードをステップインして勉強します。
深夜になると思いますが、理解できましたら、DIRのコードの勉強もしようと考えております。
しつこいようで申し訳ございません。よろしくお願いいたします。
（つづく）
（はる） 2016/02/23(火) 20:16
ところで、明日、早朝から、遠出予定で、戻りは金曜日になります。 それまでは、なかなかネットを開くことができないと思いますのでよろしくお願いします。
コメントしましたように、アップしたコードは、部分一致、かつ全列をチェックしています。 また、1行目がタイトル行という前提で書きましたので、最初のファイルは先頭から、2番目以降のファイルは 1行目をカットして2行目から取り込んでいます。
そのあたりは、最後に直しましょう。
（β） 2016/02/23(火) 20:51
（はる） 2016/02/23(火) 21:22
対象となる親フォルダは、毎回変わるものではないと思うので、Const定義にしています。書き換えてください。
使い方は、まずCommandButton1を押下すると、指定フォルダ以下のフォルダ一覧を作成します。
フォルダ毎に異なるという除外対象のキーワードを、ここでB列に手入力してください。
キーワード入力が終わった後、CommandButton2を押下することで、新シートを作成します。
Const cPATH = "C:\test\"
Private Sub CommandButton1_Click()
Dim cFiles As Variant
Dim i As Long
Columns("A:B").ClearContents
Range("A1").Resize(1, 2) = Array("フォルダ", "キーワード")
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /AD/B/S """ & cPATH & "*.*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
Cells(i + 2, "A").Value = cFiles(i)
Next i
End Sub
Private Sub CommandButton2_Click()
Dim F1 As Integer
Dim vw As Variant
Dim cFiles As Variant
Dim cKey As String
Dim cw As String
Dim i As Long
Dim j As Long
Dim jMax As Long
Dim iR As Long
Dim iSt As Long
Dim bw() As Byte
Dim csvline() As String
jMax = Cells(Rows.Count, "A").End(xlUp).Row
If jMax < 2 Then Exit Sub
Application.ScreenUpdating = False
With Workbooks.Add(xlWBATWorksheet).Sheets(1)
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A-D/B/S """ & cPATH & "*.csv""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
cKey = ""
For j = 2 To jMax
If cFiles(i) Like Cells(j, "A").Value & "*" Then
cKey = "*" & Cells(j, "B").Value & "*"
Exit For
End If
Next j
ReDim bw(FileLen(cFiles(i)) - 1)
F1 = FreeFile
Open cFiles(i) For Binary As #F1
Get #F1, , bw
Close #F1
vw = Split(StrConv(bw, vbUnicode), vbCrLf)
If 0 < iR Then
iSt = 1
End If
For j = iSt To UBound(vw) - 1
If cKey = "" Or Not vw(j) Like cKey Then
csvline() = Split(Replace(vw(j), """", ""), ",")
If 0 <= UBound(csvline()) Then
iR = iR + 1
.Cells(iR, "A").Resize(1, UBound(csvline()) + 1) = csvline()
End If
End If
Next j
Next i
End With
Application.ScreenUpdating = True
End Sub
ロジックの大きな特徴は、以下。
・サブフォルダ以下を探す部分を、コマンドプロンプトのDIRコマンドに任せることで単純化。
・ファイル読込を1回で行うことで、高速化。
（???） 2016/02/24(水) 11:12
勉強になります。早速、ステップインしてみます。
その前に。。。 とても初歩的な質問で恐縮です。
コード（英字の）のことを、もしかしたら 本当は <ロジック> と呼ぶのでしょうか？
（はる） 2016/02/24(水) 19:47
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A-D/B/S """ & cPATH & "*.csv""").StdOut().ReadAll(), vbNewLine)
の部分、インターネットで調べたところ、ｃｍｄというもので、この黒い画面でサブフォルダ以下のファイルが一度に判明するのですね。
勉強のため、昨日β様に教わったフォルダ選択ダイアログにして実行しました。
新規ブックにデータがなにも表示されなかったので、何回もステップインで確かめてみました。
さらに勉強のため調べながら、いくつか付け加えてみましたが、正しい書き方を教えていただけますでしょうか？
１．新規ブックを2シートにして、 ”ファイル一覧”を追加しました。
（???）さまの、Array を使わせてもらって、行数などが表示されるように所々にコードを加えました。
２．cKey = "*" & Cells(j, "B").Value & "*"
の部分で、キーが何も設定されていなかったので、ThisWorkbook.ActiveSheet. をつけたら設定されました。
３．部分一致を完全一致にしました。
cKey = "*" & Cells(j, "B").Value & "*" → cKey = ThisWorkbook.ActiveSheet.Cells(j, "B").Value
４．少ないサンプルで試してるので正確ではないかもしれないのですが、統合データが1行づつ足りなかったので、
If 0 < iR Then
iSt = 1
End If
をコメントアウトしたら行数は合いました。この部分はどのようにしたらいいでしょうか？
５．キーワードは、必ずA列なので、
If cKey = "" Or Not vw(j) Like cKey Then → If cKey = "" Or Split(vw(j), ",")(0) <> cKey Then
としました。
よろしくお願いいたします。
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
Option Explicit
Public cPATH As String
Private Sub CommandButton1_Click()
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
cPATH = .SelectedItems(1) & "\"
End With
Dim cFiles As Variant
Dim i As Long
Columns("A:B").ClearContents
Range("A1").Resize(1, 2) = Array("フォルダ", "キーワード")
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /AD/B/S """ & cPATH & "*.*""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
Cells(i + 2, "A").Value = cFiles(i)
Next i
End Sub
Private Sub CommandButton2_Click()
Dim W As Object
Dim F1 As Integer
Dim vw As Variant
Dim cFiles As Variant
Dim cKey As String
Dim cw As String
Dim tr As String
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim kwd As Long
Dim jMax As Long
Dim iR As Long
Dim iSt As Long
Dim bw() As Byte
Dim csvline() As String
jMax = Cells(Rows.Count, "A").End(xlUp).Row
If jMax < 2 Then Exit Sub
Application.ScreenUpdating = False
Application.SheetsInNewWorkbook = 2
Set W = Workbooks.Add
W.Worksheets(1).Name = "ファイル一覧"
W.Worksheets(2).Name = "統合データ"
W.Worksheets("ファイル一覧").Range("A1").Resize(1, 6) = Array("", "フォルダ", "ファイル名", "キーワード数", "行数", "全体行数")
With W.Worksheets("統合データ")
cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A-D/B/S """ & cPATH & "*.csv""").StdOut().ReadAll(), vbNewLine)
For i = 0 To UBound(cFiles) - 1
cKey = ""
For j = 2 To jMax
If cFiles(i) Like ThisWorkbook.ActiveSheet.Cells(j, "A").Value & "*" Then
cKey = ThisWorkbook.ActiveSheet.Cells(j, "B").Value
Exit For
End If
Next j
ReDim bw(FileLen(cFiles(i)) - 1)
F1 = FreeFile
Open cFiles(i) For Binary As #F1
Get #F1, , bw
Close #F1
vw = Split(StrConv(bw, vbUnicode), vbCrLf)
' If 0 = iR Then
' iSt = 1
' End If
cnt = 0
kwd = 0
For j = iSt To UBound(vw) - 1
' If cKey = "" Or Not vw(j) Like cKey Then
' If InStr(vw(j), cKey) = 0 Then
If cKey = "" Or Split(vw(j), ",")(0) <> cKey Then
csvline() = Split(Replace(vw(j), """", ""), ",")
If 0 <= UBound(csvline()) Then
iR = iR + 1
.Cells(iR, "A").Resize(1, UBound(csvline()) + 1) = csvline()
cnt = cnt + 1
End If
Else
kwd = kwd + 1
End If
Next j
With W.Worksheets("ファイル一覧").Cells(i + 2, 1)
.Offset(, 0).Value = i + 1
If tr <> Left(cFiles(i), InStrRev(cFiles(i), "\") - 1) Then
.Offset(, 1).Value = Left(cFiles(i), InStrRev(cFiles(i), "\") - 1)
tr = .Offset(, 1).Value
End If
.Offset(, 2).Value = Dir(cFiles(i))
.Offset(, 3).Value = kwd
.Offset(, 4).Value = cnt
.Offset(, 5).Value = kwd + cnt
End With
Next i
End With
W.SaveAs Filename:=cPATH & "CSV統合データ.xlsx", _
FileFormat:=xlOpenXMLWorkbook
Application.ScreenUpdating = True
End Sub
（はる） 2016/02/25(木) 00:22
'FSO 再帰処理でフォルダ内のCSVファイルを抽出 の部分が、大変難しいです。。。 ENDまで行っているのに、また上に昇る動き。。。もう少しステップインで理解を深めて行きたいです。
β様のご質問、１～３ の部分を失礼を承知の上、インターネットで調べながら直してみましたが、モタモタした感じです。。。申し訳ありません。
正解のコードを教えていただけますでしょうか。
それと、新規ブックにファイル一覧というシートを挿入して、行数などを記録したら確認が出来ていいかなと思い追加してみました。
こちらも調べながらの作業でしたので、正解を どうかよろしくお願いいたします。
ご面倒な続きをお願いして、申し訳ございません。
Option Explicit
Public cnt As Long Public kwd As Long Public auti As Long Public maxi As Long
Sub Sample()
Dim pPath As String
Dim pFold As Object
Dim ignore As String
Dim fso As Object
Dim fPool As Variant
Dim dic As Object
Dim fPath As Variant
Dim shT As Worksheet
Dim shF As Worksheet
Dim shM As Worksheet
Dim done As Boolean
Dim W As Object
Dim tr As String
Dim i As Long
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
pPath = .SelectedItems(1)
End With
'除外文字列指定
ignore = Application.InputBox("除外文字列を指定してください。" & vbLf & _
"もし除外文字列がない場合はこのままＯＫボタンを押してください", Type:=2)
If ignore = "False" Then Exit Sub 'キャンセルボタン
'フォルダからのCSVファイル抽出(含むサブフォルダ）
Set pFold = fso.GetFolder(pPath)
GetFiles pFold, dic
If dic.Count = 0 Then
MsgBox "ファイルがありません"
Exit Sub
End If
'統合用新規ブックの作成(シートは2枚のみ）
Set shT = Workbooks.Add(xlWBATWorksheet).Sheets(1)
shT.Name = "統合データ"
Worksheets.Add(Before:=Worksheets(Worksheets.Count)).Name = ("ファイル一覧")
Set shM = Worksheets("ファイル一覧")
shM.Range("A1").Resize(1, 6) = Array("", "フォルダ", "ファイル名", "キーワード数", "行数", "全体行数")
i = 2
'抽出したCSVファイルの取り出し
For Each fPath In dic
Set shF = Workbooks.Open(fPath).Sheets(1)
CutData shF, ignore
If Not done Then
shF.Cells.Copy shT.Range("A1")
done = True
Else
shF.Range("A1", shF.UsedRange).Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
With shM.Cells(i, 1)
.Offset(, 0).Value = i - 1
If tr <> Left(fPath, InStrRev(fPath, "\") - 1) Then
.Offset(, 1).Value = Left(fPath, InStrRev(fPath, "\") - 1)
tr = .Offset(, 1).Value
End If
.Offset(, 2).Value = Dir(fPath)
.Offset(, 3).Value = kwd
.Offset(, 4).Value = maxi - kwd
.Offset(, 5).Value = maxi
i = i + 1
End With
shF.Parent.Close False
Next
'新規ブックを保存。同名のものがあれば無条件上書き。
Application.DisplayAlerts = False
shT.Parent.SaveAs Filename:=ThisWorkbook.Path & "\CSV統合データ.xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Application.Goto shT.Range("A1")
Application.ScreenUpdating = True
MsgBox "統合完了"
End Sub
'FSO 再帰処理でフォルダ内のCSVファイルを抽出
Private Sub GetFiles(pFold As Object, dic As Object)
Dim myFile As Object
Dim myFolder As Object
'ファイル名を列挙
For Each myFile In pFold.Files
If LCase(Right(myFile.Path, 4)) = ".csv" Then dic(myFile.Path) = True
Next myFile
'サブフォルダを検索
For Each myFolder In pFold.Subfolders
Call GetFiles(myFolder, dic)
Next myFolder
End Sub
'除外文字列の処理
Private Sub CutData(sh As Worksheet, ignore As String)
' Dim c As Range
' Dim f As Range
Dim r As Range
Dim auti As Long
If ignore = "" Then Exit Sub
maxi = Cells(Rows.Count, 1).End(xlUp).Row
' Set c = sh.UsedRange.Find(What:=ignore, LookAt:=xlPart)
Rows(1).Insert
Range("A1:B1").AutoFilter Field:=1, Criteria1:=ignore
auti = Cells(Rows.Count, 1).End(xlUp).Row
Set r = Range("A2:A" & auti).SpecialCells(xlCellTypeVisible)
kwd = r.Count
r.EntireRow.Delete
sh.AutoFilterMode = False
Rows(1).Delete
' If c Is Nothing Then Exit Sub
' Set f = c
'
'
'
' Do
' If r Is Nothing Then
' Set r = c.EntireRow
' Else
' Set r = Union(r, c.EntireRow)
' End If
'
'
'
' Set c = sh.UsedRange.FindNext(c)
'
'
'
' Loop While c.Address <> f.Address
'
'
'
' r.Delete
End Sub
（はる） 2016/02/25(木) 03:48
ロジックとは、論理構造とか仕組みとか考え方の意味で使っています。プログラムの一部とか、サブプロシジャとかサブルーチンとかの狭い範囲になります。
ちなみに、黒いウィンドウはコマンドプロンプトです。昔のMS-DOSのコマンドが使えるやつですね。
VBAのDir関数では、指定した階層のフォルダしか拾えない、しかも1つだけ、という不便さがありますが、
DOSコマンドの方はサブフォルダまでまとめて表示できるオプションがあるのです。
これを利用し、更にコマンドの終了待ちや行の分解を精錬していったのが、ご指摘の1行です。
まぁ、ここはDIRコマンド後のオプションだけ理解して、あとはブラックボックス状態でも構いませんよ。
（正攻法は再帰(自分で自分を呼び出すことで、サブのサブを処理)なのですが、これはコーディングにコツがあり、理解が難しいと思っています）
次にコーディング部分。
フォルダ選択ダイアログに変えてみる、というトライは、とても良いですね。コーディングもきっちり目的に合わせて改造してますし。
その調子でいくと、すぐに質問する必要がなくなるくらいに上達しますよ。
改良するとして、選択したフォルダのフルパス文字列を、どこかのセルに保存しておいてはいかがでしょう？
そうすれば、2つ目のボタンを押したときは、ダイアログから選択する必要がなくなりますよね。
ThisWorkbook.ActiveSheet. を付けないとキーワードが拾えなかった、というのは、ブックを分けたためですね。
なお、ThisWorkbook.ActiveSheet. の部分は、Me. に置き換えられそうです。お試しください。
iSt = 1 の部分について。
ここは、1つ目のシートだけ1行目（タイトル行）もコピーし、2シート目からは2行目以降になるようにしました。
タイトル行は無いという事でしょうか？ そうであれば、常に iSt = 0 でOKです。
（???） 2016/02/25(木) 10:35
まだエクセルの環境がないので、とりあえずざくっとしたコメントだけ。
上級者版は、???さんにお任せするとして、βがアップした基礎編で。
・部分一致
完全一致なら 一か所ある Dindメソッドの xlPart を xlWhole に。
・対象列はA列のみ
FindメソッドとFindNextメソッドの UsedRange を UsedRange.Columns("A") に。
（本来はフィルタリングが使えるところですが、後述のタイトル行の話があるので、とりあえずは FindとFindNextで）
・タイトル行があるもののあるし、ないものもある
う～ん、これはやっかいですね。
タイトル行にこだわったのは、最初のファイルはタイトル行付き、2番目のファイルからは、タイトル行をのぞいたデータ行のみを
貼り付けたいだろうとかんがえたからです。
もし、タイトル行のあるものは、２つめのファイル以降もタイトル行含めてコピペなら、簡単ですが、タイトル行がある場合は2行目から、
タイトル行がない場合は1行目からということになると、最初の行がタイトル行かどうかの判断が必要です。
判断できる基準はありますか？
（β） 2016/02/25(木) 17:48
iSt = 1 の部分についてですが、納得です、なるほどです。そうだったのですね。
最初の行は、タイトル行ではないのです。誠に失礼致しました。
コマンドプロンプト、DOSコマンドなど内容はわからなくても、このような便利な存在を利用する意味を教えていただけだけでも大変勉強になりました。
・フォルダのフルパス文字列を、どこかのセルに保存
・ThisWorkbook.ActiveSheet. の部分は、Me. に置き換えられそうです。
早速勉強してみます。
βさま。
お忙しいところ、コメントをありがとうございます。
・xlPart を xlWhole に。
・UsedRange を UsedRange.Columns("A") に。
ご指摘の箇所を、確かめてみます。
タイトル行ですが、私の説明不足でご迷惑をおかけしております。。。
ひとつのCSVブックのデータ途中に、何行も出現するタイトル行を統合データに加えないために、キーワードの設定をしたいのです と言ったほうが正解だったかもしれません。。。。（純粋にデータだけの統合です）
せっかくコードを反映させてくださったのに、今頃になって大変申し訳ありません！
（はる） 2016/02/25(木) 22:06
>>ひとつのCSVブックのデータ途中に、何行も出現するタイトル行を統合データに加えないために、キーワードの設定をしたいのです
なるほど。タイトル行を（すべて）加えないようにするなら
shF.Range("A1", shF.UsedRange).Offset(1).Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
これを
shF.Cells.Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
にしてください。
ただ、これだと、最初のタイトル行もカットされますが。 統合されるファイルの先頭にだけはタイトル行をいれたいということなら、もうひとひねり必要ですが。
なお、おもしろそうなので、???さんと同じく DIRコマンドでの抜出し、標準機能のファイル読みこみに加え 正規表現でのタイトル除外、標準機能でのファイル統合、そのエクセルへの抽出 といった流れのコードも （自分自身の勉強のために）書いてみようかなと思っています。
（β） 2016/02/26(金) 06:53
・ただ、これだと、最初のタイトル行もカットされますが。
そうですね。。。
では、キーワードの行を1行だけ統合データの一番上にコピーする ようにできますでしょうか？
途中で変更して、申し訳ありません。
正規表現。。。想像することもできませんが、どうかよろしくお願いいたします。
（???）さま。
・フォルダのフルパス文字列を、どこかのセルに保存
したところ、2番目のボタンを続けて何回押下しても、フォルダが変わることが無くなり、復習しやすくなりました。
・Me という便利なキーワードは、シートモジュールにだけ使えるものなのですね。
大変勉強になりました。
（はる） 2016/02/26(金) 15:21
正規表現版は、これから書いてみようかなと。でも、根気が続かず、途中で放り投げることもありますから 期待しないでください。
とりあえず基礎編で、最初のみタイトル行をセットするコードです。フルセット、以下。
Sub Sample2()
Dim pPath As String
Dim pFold As Object
Dim ignore As String
Dim fso As Object
Dim fPool As Variant
Dim dic As Object
Dim fPath As Variant
Dim shT As Worksheet
Dim shF As Worksheet
Dim done As Boolean
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
pPath = .SelectedItems(1)
End With
'除外文字列指定
ignore = Application.InputBox("除外文字列を指定してください。もし、除外文字列がない場合は" & vbLf & _
"このままＯＫボタン、あるいはキャンセルボタンを押してください", Type:=2)
'フォルダからのCSVファイル抽出(含むサブフォルダ）
Set pFold = fso.GetFolder(pPath)
GetFiles pFold, dic
If dic.Count = 0 Then
MsgBox "ファイルがありません"
Exit Sub
End If
'統合用新規ブックの作成(シートは1枚のみ）
Set shT = Workbooks.Add(xlWBATWorksheet).Sheets(1)
'抽出したCSVファイルの取り出し
For Each fPath In dic
Set shF = Workbooks.Open(fPath).Sheets(1)
CutData shF, ignore, done
If Not done Then
shF.Cells.Copy shT.Range("A1")
done = True
Else
shF.Range("A1", shF.UsedRange).Copy shT.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
shF.Parent.Close False
Next
'新規ブックを保存。同名のものがあれば無条件上書き。
Application.DisplayAlerts = False
shT.Parent.SaveAs Filename:=ThisWorkbook.Path & "\新しいブック名.xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Application.Goto shT.Range("A1")
Application.ScreenUpdating = True
MsgBox "統合完了"
End Sub
'FSO 再帰処理でフォルダ内のCSVファイルを抽出
Private Sub GetFiles(pFold As Object, dic As Object)
Dim myFile As Object
Dim myFolder As Object
'ファイル名を列挙
For Each myFile In pFold.Files
If LCase(Right(myFile.Path, 4)) = ".csv" Then dic(myFile.Path) = True
Next myFile
'サブフォルダを検索
For Each myFolder In pFold.subfolders
Call GetFiles(myFolder, dic)
Next myFolder
End Sub
'除外文字列の処理
Private Sub CutData(sh As Worksheet, ignore As String, done As Boolean)
Dim c As Range
Dim f As Range
Dim r As Range
Dim myR As Range
If ignore = "" Then Exit Sub
With sh.UsedRange.Columns(1)
If done Then
Set myR = .Cells
Else
Set myR = .Offset(1).Resize(.Rows.Count - 1)
End If
End With
Set c = myR.Find(What:=ignore, LookAt:=xlPart)
If c Is Nothing Then Exit Sub
Set f = c
Do
If r Is Nothing Then
Set r = c.EntireRow
Else
Set r = Union(r, c.EntireRow)
End If
Set c = myR.FindNext(c)
Loop While c.Address <> f.Address
r.Delete
End Sub
（β） 2016/02/26(金) 20:37
実行してみたところ、統合シート1行目に、なぜかタイトル行が表示されていません。。。
もう少し やってみます。
（はる） 2016/02/27(土) 04:50
>>統合シート1行目に、なぜかタイトル行が表示されていません。。。
各ファイルの1行目が必ずタイトル行という認識で、最初のファイルは2行目以降の除外、２つめのファイルからは1行目からの除外にしています。
なので、もし、必ずしも1行目がタイトル行ではない。だけど、どこかに必ずタイトル行があるということなら もう１ひねりします。
もし、最初のファイル（どれが最初かは、その時のフォルダ内のファイルのファイル名によりますが）が タイトル行を全く持っていないということなら、ちょっとお手上げですけど。
（β） 2016/02/27(土) 06:11
もし、指摘の状況が、1行目が必ずしもタイトル行ではない、でも、どこかにタイトル行があれば それを統合ファイルの1行目にタイトル行としてセットしたいという要件であれば、CutData のみ以下に。 そうではない、1行目にタイトル行があったのになくなった！！ ということなら悩んでしまいますが・・
'除外文字列の処理
Private Sub CutData(sh As Worksheet, ignore As String, done As Boolean)
Dim c As Range
Dim f As Range
Dim r As Range
Dim myR As Range
Dim sv As Variant
If ignore = "" Then Exit Sub
Set myR = sh.UsedRange.Columns(1)
Set c = myR.Find(What:=ignore, LookAt:=xlPart)
If c Is Nothing Then Exit Sub
Set f = c
If Not done Then sv = sh.UsedRange.Rows(c.Row)
Do
If r Is Nothing Then
Set r = c.EntireRow
Else
Set r = Union(r, c.EntireRow)
End If
Set c = myR.FindNext(c)
Loop While c.Address <> f.Address
r.Delete
If IsArray(sv) Then
sh.Rows(1).Insert
sh.Range("A1").Resize(, UBound(sv, 2)).Value = sv
End If
End Sub
（β） 2016/02/27(土) 09:38
1行目が必ずタイトル行ではなく、
タイトル行が全くないファイルはありません。
Sub Sample2 の、最初のコードの内容ですが、
If Not done Then
shF.Cells.Copy shT.Range("A1")
done = True
この部分で、最初のファイルを統合シートにそのままコピー
そのあと、Private Sub CutData で、1列目の
始まりの行を含めた範囲を設定、
（更新コードでは、1列目全てがセル範囲。最高のファイルの時のキーワードの行をsvに設定。）
1列目にキーワードがある行を見つけて、Union(r, c.EntireRow) で、キーワードの行を r に追加していき、
最後に r をいっぺんに削除する。
（更新コードでは、この後タイトル行を1行目に挿入する。）。。のような感じでしょうか？
勘違いしている所を指摘して下さい。
doneを使うこと、EntireRow、Union(r, c.EntireRow)、変数（？）の設定の仕方など、
初めて調べることばかりで、全てのコードが大変勉強になります。
今から、難しいサブフォルダ部分をステップインします。
1点だけ質問させてください。
更新して下さったコードの最後で、タイトル行を挿入する所です。
列の最大数を調べる UBound(sv, 2) という部分です。
この、 2 を調べると、2次元ということだそうですが、2次元とは列のことなのでしょうか？
長くなりましたが、よろしくお願いいたします。
（はる） 2016/02/27(土) 12:11
>>Sub Sample2 の、最初のコードの内容ですが、～ 勘違いしている所を指摘して下さい。
その理解で結構かと思います。
>> 今から、難しいサブフォルダ部分をステップインします。
いわゆる再帰処理、自分の中から自分自身を呼び出す処理でわかりにくいかもしれませんが、がんばってください。
>>2次元とは列のことなのでしょうか？
配列には列だけを持つ1次元配列、行と列を持つ2次元配列（シートのセル領域のようなもの）、さらには3次元、4次元・・とあります。 で、sv には 最初に現れたタイトル行1行を取り込んでいます。このとき、sv は 1行、複数列の2次元配列になります。 2次元配列で UBound(配列,1) ・・つまり配列の１次元目の項目数（行数）・・今回のケースでは常に1、 UBound(配列,2) ・・つまり配列の2次元目の項目数（列数）・・が実際のＣＳＶファイルの列数になります。
なお、ちょっと申し上げていた、別処理コードを書いてみました。 参考うまでに、レスを変えてアップします。
（β） 2016/02/27(土) 14:18
ちなみに、こちらで持っている、フォルダ（サブフォルダも含める）からのファイル名抽出処理ですが 処理の早いものから
１．APIのFindFirstFileやFindNextFileによる処理 ２．DIRコマンド(RUN)を使った処理 ３．ShellApplicationを使った処理 ４．DIRコマンド(Exec)を使った処理(???さんから提示の方法です） ５．ぐ～んと効率が悪くなって FSO
となっています。
ただし、たとえばサブフォルダも含めて、500個ぐらいのファイルであれば、１．～４．は （こちらの環境で）0.5秒～2秒、 ５．でも 10秒弱ですから、そこはわかりやすいものを使えばいいと思います。 むしろ、そのあと、抽出されたファイル名に従って、そのファイルを取り込んで統合する、そこの処理が 処理時間全体にとってはインパクトがある部分で、基礎編としてアップした、【ブックとして開く】、これが きわめて遅い処理になります。ここは、???さんが提示されたようなＶＢＡ標準のファイル処理を使う、あるいは 特定のファイルを開くわけですから、FSOのテキストファイル処理機能を使っても、ブックとして開くことに比較すれば かなり効率はよくなるはず。
以下のコードでは、
・ShellApplication でファイル一覧を取得 ・各ファイルはFSOのテキストファイル処理機能を使って開き ・除外文字列を正規表現で一括処理をして ・それを、やはりFSOを使って統合テキストファイルに書きこみ ・最後に、そのテキストファイルを、ブックとして開いてエクセルブックとして保存
こういったことをしてみました。
大急ぎで書きなぐった感があり、おおよその確認はしましたが、どこかに間違いがあるかもしれません。 正規表現処理も、もっとスマートなパターンの組み立てもできるかもしれませんが、力技です。
（β） 2016/02/27(土) 14:22
Sub Sample4()
Dim pPath As Variant
Dim pFold As Object
Dim ignore As String
Dim fso As Object
Dim fPool As Variant
Dim dic As Object
Dim fPath As Variant
Dim shT As Worksheet
Dim shF As Worksheet
Dim done As Boolean
Dim reg As Object
Dim wsh As Object
Dim tmpPath As String
Dim rtn As Long
Dim fNo As Integer
Dim buf() As Byte
Dim s As String
Dim outPath As String
Dim outTxt As Object
Dim inTxt As Object
Dim objFolder As Object
Dim mt As Object
Dim sv As String
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
Set reg = CreateObject("VBScript.RegExp")
Set wsh = CreateObject("WScript.SHell")
reg.Global = True
'フォルダ選択
With Application.FileDialog(msoFileDialogFolderPicker)
If Not .Show Then Exit Sub 'キャンセルボタン
pPath = .SelectedItems(1)
End With
'除外文字列指定
ignore = Application.InputBox("除外文字列を指定してください。もし、除外文字列がない場合は" & vbLf & _
"このままＯＫボタン、あるいはキャンセルボタンを押してください", Type:=2)
'フォルダからのCSVファイル抽出(含むサブフォルダ）
Set objFolder = CreateObject("Shell.Application").Namespace(pPath)
Call GetFiles(objFolder.Items, dic)
If dic.Count = 0 Then
MsgBox "ファイルがありません"
Exit Sub
End If
'作業用出力ファイルの作成
outPath = Environ$("Temp") & "\out.tmp"
On Error Resume Next
Kill outPath
On Error GoTo 0
Set outTxt = fso.OpenTextFile(Filename:=outPath, IOMode:=8, Create:=True) '8:ForAppending
'抽出されたcsvファイルの読み込みと出力ファイルへの書き込み
For Each fPath In dic
Set inTxt = fso.OpenTextFile(Filename:=fPath, IOMode:=1) '1:ForReading
s = inTxt.readAll
If ignore <> "" Then '除外文字指定（タイトル行処理）
'============================================================
'除外文字列がメタ文字だった場合のエスケープ処理
reg.Pattern = "([\^\$\?\*\+\.\|\{\}\\\[\]\(\)])"
ignore = reg.Replace(ignore, "\$1")
'最初に現れる除外文字（タイトル行）をさがす
reg.Pattern = "(^" & ignore & ",.*(?=[\n$]))|(\n" & ignore & ",.*(?=[\n$]))"
'最初のファイルのみ最初に現れる除外文字（タイトル行）をさがす
sv = ""
If Not done Then
Set mt = reg.Execute(s)
If mt.Count > 0 Then
sv = mt(0).Value 'その行を保管
End If
End If
'除外文字列行（タイトル行）の一括削除
s = reg.Replace(s, "")
'=============================================================
End If
inTxt.Close
If s <> "" Then outTxt.write sv
outTxt.write s
done = True
Next
outTxt.Close
'出力ファイルをエクセルブックとして開き、
Workbooks.OpenText Filename:=outPath, _
Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, TrailingMinusNumbers:=True
'先頭の改行コードによる空白行の削除
If ActiveSheet.UsedRange.Row <> 1 Then Rows(1).Delete
'エクセルブックとして名前を付けて保存。同名のものがあれば無条件上書き。
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\新しいブック名.xlsx", FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'出力用テキストファイルの削除
Kill outPath
MsgBox "統合完了"
End Sub
'ShellApplicationを使った再帰処理
Private Sub GetFiles(fldItems As Object, dic As Object)
Dim objFolderItems As Object
Dim objItem As Object
For Each objItem In fldItems
If objItem.isfolder Then
Set objFolderItems = objItem.GetFolder
Call GetFiles(objFolderItems.Items, dic)
Else
dic(objItem.Path) = True
End If
Next
End Sub
（β） 2016/02/27(土) 14:22
↑ 不要になった変数や使わなくなったオブジェクトの生成が残っています。 がいにはなりませんので無視してください。
（β） 2016/02/27(土) 14:31
案の定、コードにミスがありました。
sv = ""
これは、 If ignore <> "" Then '除外文字指定（タイトル行処理） の上に移動してください。
それと、 If s <> "" Then outTxt.write sv
これは If sv <> "" Then outTxt.write sv
にしてください。
（β） 2016/02/27(土) 14:49
それに、今よりも更にまた目の醒めるようなコード、ありがとうございます！
reg というのが、正規表現の設定ということしか分からないです。。。
これから、再帰処理を理解したあと、統合ファイルにファイル一覧というシートを追加してみて、
ファイル名、件数などのコードを追加する ようなことをやってみようと思います。
その後、Sample4 をステップインさせていただきます！
楽しみが増えました。本当に、ありがとうございました。
（はる） 2016/02/27(土) 14:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.