Option Explicit
Dim outSheet As Worksheet
Dim inputFileFolder As String
Dim path As String
Dim fileExFlg As Boolean
'実行ボタンクリック
Private Sub btn_Generate_Click()
If Len(Sheet1.inputFileFolder.Text) = 0 Then
Call MsgBox("入力フォルダを入力してください。", vbOKOnly + vbCritical)
Exit Sub
End If
Call mainPross(Sheet1.inputFileFolder.Text)
End Sub
' 選択ボタンクリック
Public Sub selectButton_Click()
Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Sheet1.inputFileFolder.Text
If Not Application.FileDialog(msoFileDialogFolderPicker).Show Then
Exit Sub
End If
Sheet1.inputFileFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
End Sub
Public Sub mainPross(inputFileFolder As String)
Windows.Application.ScreenUpdating = False
Call ExecEachFolder(inputFileFolder, "**")
End Sub
'入力ディレクトリ再帰して、全部ファイルを繰り返す。
Public Function ExecEachFolder(folderPath As String, kaku As String)
Dim targetWorkbook As Workbook
Dim FSO As New FileSystemObject
Dim fe As FILE
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.ScreenUpdating = False
'check CSV path
checkPach folderPath
'check format file1 path
File_DirSample Sheet1.TextBox1.Value
'check format file2 path
File_DirSample Sheet1.TextBox2.Value
'check output path
checkPach Sheet1.TextBox3.Value
'フォーマットファイルを開く
Set targetWorkbook = Workbooks.Open(Sheet1.TextBox1.Value)
Set targetWorkbook = Workbooks.Open(Sheet1.TextBox2.Value)
' フォルダ内のCSVファイルを処理する
For Each fe In FSO.GetFolder(folderPath).Files
Dim folderNm As String
folderNm = Split(folderPath, "\")(UBound(Split(folderPath, "\")))
Dim fp As String: fp = fe.path
Dim en As String: en = LCase(FSO.GetExtensionName(fp))
If en = "csv" Then
'ファイル存在の場合、ファイルをOPENして、処理を行う
doBlogic fe.path
ElseIf en = "xlsx" Then
End If
Set fe = Nothing
Next
' サブフォルダに再帰的に検索する
Dim fr As Folder
For Each fr In FSO.GetFolder(folderPath).SubFolders
Call ExecEachFolder(fr.path, kaku)
Set fr = Nothing
Next
Set FSO = Nothing
Windows("f1.xlsx").Activate
ActiveWorkbook.SaveAs Filename:=Sheet1.TextBox3.Value & "/" & Replace(Replace(Replace(Now, "/", ""), ":", ""), " ", "") & "f1.xlsx"
ActiveWindow.Visible = True
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("f2.xlsx").Activate
ActiveWorkbook.SaveAs Filename:=Sheet1.TextBox3.Value & "/" & Replace(Replace(Replace(Now, "/", ""), ":", ""), " ", "") & "f2.xlsx"
ActiveWindow.Visible = True
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Close
a1: Exit Function
End Function
'ファイルをOPENして、自分の業務処理ロジックを書く
Public Function doBlogic(filepath As String)
On Error GoTo 1
'TODO TextBox1の値をチェック必要
'ファイル開く場合、非表示
'CSVファイルの名前を取得する
Dim pos As String
Dim pathName As String
Dim filename1 As String
pos = InStrRev(filepath, "\")
pathName = Left(filepath, pos)
filename1 = Mid(filepath, pos + 1)
'CSVファイルよみ、EXCELファイルに書く
Dim buf As String
Open filepath For Input As #1
Do Until EOF(1)
Line Input #1, buf
'読み込んだデータをセルに代入する
Dim tmp As Variant
Dim n As Integer
tmp = Split(buf, ",")
n = n + 1
If filename1 = "c1.csv" Then
Windows("f1.xlsx").Activate
Dim i As Integer
For i = 0 To UBound(tmp)
Cells(n, i + 1) = tmp(i)
Next i
ElseIf filename1 = "c2.csv" Then
Windows("f2.xlsx").Activate
For i = 0 To UBound(tmp)
Cells(n + 1, i + 1) = tmp(i)
Next i
ElseIf filename1 = "c3.csv" Then
Windows("f1.xlsx").Activate
For i = 0 To UBound(tmp)
Cells(n + 2, i + 1) = tmp(i)
Next i
Windows("f2.xlsx").Activate
For i = 0 To UBound(tmp)
Cells(n + 3, i + 1) = tmp(i)
Next i
End If
Loop
Close #1
1:
End Function
'checp path
Sub checkPach(filepath As String)
''Subフォルダが存在するかどうか調べます
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(filepath) Then
Else
MsgBox filepath & "フォルダは存在しません"
End
End If
Set FSO = Nothing
End Sub
'check DIR
Sub File_DirSample(filepath As String)
Dim flSample As String
'ファイル名の取得
flSample = Dir(filepath)
'ファイルの存在有無を判定
If Len(flSample) <> 0 Then
Else
'「無し」の結果をメッセージボックスで表示
MsgBox (filepath & "は存在しません"), vbCritical
End
End If
End Sub
