Option Explicit
Dim strFolder As String
Dim strThisBook As String
Dim strExtension As String
Dim strBook As String
Dim strSheet As String
Dim intRowSta As Integer
Dim intRowEnd As Integer
Dim intColSta As Integer
Dim intColEnd As Integer
Sub main()
strThisBook = ThisWorkbook.Name '開いているブック
strFolder = Cells(1, 2).Value 'フォルダパス退避
strExtension = Cells(2, 2).Value '拡張子退避
If Dir(strFolder, vbDirectory) = "" Then 'フォルダの存在確認
MsgBox "指定のフォルダは存在しません。"
Exit Sub
End If
Call FileSearch(strFolder) '指定フォルダ検索
MsgBox "END"
End Sub
'フォルダ内を指定拡張子分を取得
Sub FileSearch(strPath As String)
strBook = Dir(strPath & "\*." & strExtension, vbNormal) '拡張子指定
Do While Trim(strBook) <> "" 'ファイルが見つからなくなるまで繰り返す
Call xlsOpenClose 'ファイルオープン
strBook = Dir() '次のファイル名を取得
Loop
End Sub
'エクセルファイルをオープン＆クローズ
Sub xlsOpenClose()
Dim objSheet As Object
Workbooks.Open Filename:=strFolder & "\" & strBook 'エクセルオープン
Debug.Print strFolder & "\" & strBook
Application.ScreenUpdating = False '画面更新停止
For Each objSheet In ActiveWorkbook.Sheets 'シート検索
Worksheets(objSheet.Name).Activate
strSheet = objSheet.Name
Select Case strBook
Case "test1.xls" '各ブックの指定
Select Case strSheet
Case "Sheet1"
intRowSta = 4 '各シートの開始行指定
intColSta = 2 '各シートの開始列指定
getLastRowCol '各シートの最終行列取得
Call outCsv
Case Else
End Select
Case "test2.xls"
Select Case strSheet
Case "Sheet1"
intRowSta = 5
intColSta = 3
getLastRowCol
Call outCsv
Case "Sheet3"
intRowSta = 2
intColSta = 2
getLastRowCol
Call outCsv
Case Else
End Select
Case Else
End Select
Next objSheet
Application.ScreenUpdating = True '画面更新開始
Workbooks(strBook).Close SaveChanges:=False 'エクセルクローズ
End Sub
'ＣＳＶファイル出力
Sub outCsv()
Dim i As Integer
Dim j As Integer
Dim strCsvFileName As String
strCsvFileName = strFolder & "\" & Format(Date, "yymmdd") & "-" & getBaseFileNmae(strBook) & "-" & strSheet & ".csv" 'ＣＳＶファイルをセット
Open strCsvFileName For Output Access Write As #1 'ＣＳＶファイルのオープン
For i = intRowSta To intRowEnd 'ＣＳＶファイル出力
For j = intColSta To intColEnd - 1
If j = intColSta Then '先頭カラム
Write #1, String(7 - Len(Cells(i, j).Value), "0") & Cells(i, j).Value; 'ゼロ埋め
Else
Write #1, Cells(i, j).Value;
End If
Next j
Write #1, Cells(i, j).Value
Next i
Close #1 'ＣＳＶファイルのクローズ
End Sub
'最終行列の取得
Sub getLastRowCol()
With Range("A1").SpecialCells(xlLastCell)
intRowEnd = .Row '入力最終行
intColEnd = .Column '入力最終列
End With
End Sub
'ファイル名称を取得（拡張子分離）
Function getBaseFileNmae(strParm As String) As String
Dim objFileSys As Object
Dim strExt As String
Set objFileSys = CreateObject("Scripting.FileSystemObject")
getBaseFileNmae = ""
strExt = objFileSys.GetExtensionName(strParm) '拡張子抽出
Debug.Print strExt
getBaseFileNmae = Left(strParm, Len(strParm) - (Len(strExt) + 1)) '拡張子外抽出
Debug.Print getBaseFileNmae
Set objFileSys = Nothing
End Function