ExcelVBA ひな形

# ExcelVBA ひな形

```ruby:cmdGetFileList_Click

/**************************************************/
/* cmdGetFileList_Click()                         */
/**************************************************/
Option Explicit

Private Sub cmdGetFileList_Click()
On Error GoTo errorHandler
    
    Call ExcelSpeedUpOn             '高速化オン
    
    Dim StartTime As Date   '処理の開始時刻を格納する変数領域
    Dim EndTime As Date     '処理の終了時刻を格納する変数領域
    
    StartTime = Time
    
    Call setFileList(Cells(1, 5))   'フォルダパスを入力するセル
    
    Call ExcelSpeedUpOn             '高速化オフ
    
    '処理時間MsgBox
    Call ProcTmMsgBox("ファイル一覧を取得しました。", StartTime)
    
    Exit Sub

errorHandler:
    Call ProcErrMsgBox("エラー番号:" & Err.Number & vbCrLf & _
    "エラー内容:" & Err.Description, StartTime)

End Sub

Sub setFileList(searchPath)
Dim startCell As Range
Dim maxRow As Long
Dim maxCol As Long

    Set startCell = Cells(5, 2) 'このセルから出力し始める
    startCell.Select
    
    'シートをいったんクリア
    maxRow = startCell.SpecialCells(xlLastCell).Row
    maxCol = startCell.SpecialCells(xlLastCell).Column
    Range("A6:IV" & Rows.Count).Clear
    
    Range("B4").Value = "フォルダ"
    Range("C4").Value = "ファイル名"
    Range("D4").Value = "更新日時"
    Range("E4").Value = "更新日"
    Range("F4").Value = "更新日時"
    Range("G4").Value = "サイズ(KB)"
    Range("H4").Value = "サイズ(Byte)"
    
    Call getFileList(searchPath)
    startCell.Select

End Sub

Sub getFileList(searchPath)
Dim FSO As New FileSystemObject
Dim objFiles As File
Dim objFolders As Folder
Dim separateNum As Long

    'サブフォルダ取得
    For Each objFolders In FSO.getFolder(searchPath).SubFolders
        Call getFileList(objFolders.Path)
    Next
    
    'ファイル名の取得
    For Each objFiles In FSO.getFolder(searchPath).Files
        separateNum = InStrRev(objFiles.Path, "\")
        'セルにパスとファイル名を書き込む
        ActiveCell.Value = Left(objFiles.Path, separateNum - 1)
        ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum)
        ActiveCell.Offset(0, 2).Value = Format(FileDateTime(objFiles), "YYYY/MM/DD HH:MM:SS")   '更新日時
        ActiveCell.Offset(0, 3).Value = Format(FileDateTime(objFiles), "YYYY/MM/DD")            '更新日付
        ActiveCell.Offset(0, 4).Value = Format(FileDateTime(objFiles), "HH:MM:SS")              '更新時刻
        ActiveCell.Offset(0, 5).Value = Format((FileLen(objFiles) / 1024), "#,###")
        ActiveCell.Offset(0, 6).Value = Format(FileLen(objFiles), "#,###")
        ActiveCell.Offset(1, 0).Select
    Next
End Sub

/**************************************************/
/* Module1                                        */
/**************************************************/
Option Explicit

'/*******************************************************************
'/* 処理時間Msgbox
'/*******************************************************************
Public Sub ProcTmMsgBox(Msg As String, StartTime As Date)
Dim StopTime As Date

    StopTime = Time - StartTime
    
    MsgBox Now & vbLf _
            & Msg & vbLf _
            & "処理時間:" & Hour(StopTime) & "時" & Minute(StopTime) & "分" & Second(StopTime) & "秒"

End Sub

'/*******************************************************************
'/* 処理時間ErrorMsgbox
'/*******************************************************************
Public Sub ProcErrMsgBox(Msg As String, StartTime As Date)
    Dim StopTime As Date
    
    StopTime = Time - StartTime
    
    MsgBox Now & vbLf _
            & Msg & vbLf _
            & "処理時間:" & Hour(StopTime) & "時" & Minute(StopTime) & "分" & Second(StopTime) & "秒" _
            , vbCritical + vbOKOnly
            
End Sub

'/*******************************************************************
'/* Excel高速化オン
'/*******************************************************************
Public Sub ExcelSpeedUpOn()

    With Application
        .ScreenUpdating = False                 ' 描画を停止する
        .EnableEvents = False                   'イベント発生を抑止する
        .Calculation = xlCalculationManual      ' 手動計算にする
    End With

End Sub

'/*******************************************************************
'/* Excel高速化オフ
'/*******************************************************************
Public Sub ExcelSpeedUpOff()

    With Application
        .ScreenUpdating = True                  ' 描画を再開する
        .EnableEvents = False                   ' イベント発生を再開する
        .Calculation = xlCalculationAutomatic   ' 自動計算にする
    End With


End Sub

'/*******************************************************************
'/* シート名取得
'/*******************************************************************
Public Sub getSheet()
Dim objCn As New ADODB.Connection
Dim objRS As ADODB.Recordset
Dim sFile As String
Dim sSheet As String
Dim i As Long

    sFile = Application.GetOpenFilename(fileFilter:="Excelファイル,*.xls*")
    If sFile = "False" Then
        Exit Sub
    End If
    
    With objCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0"
        .Open sFile
        Set objRS = .OpenSchema(ADODB.adSchemaTables)
    End With
    
    i = 1
    Do Until objRS.EOF
        sSheet = objRS.Fields("TABLE_NAME").Value
        If Right(sSheet, 1) = "$" Or Right(sSheet, 2) = "$'" Then
            If Right(sSheet, 1) = "$" Then
                sSheet = Left(sSheet, Len(sSheet) - 1)
            End If
            If Right(sSheet, 2) = "$'" Then
                sSheet = Left(sSheet, Len(sSheet) - 2)
            End If
            If Left(sSheet, 1) = "'" Then
                sSheet = Mid(sSheet, 2)
            End If
            sSheet = Replace(sSheet, "''", "'")
            Cells(i, 1) = sSheet
            i = i + 1
        End If
        objRS.MoveNext
    Loop
    objRS.Close
    objCn.Close
    Set objRS = Nothing
    Set objCn = Nothing
End Sub

'/*******************************************************************
'/* 引数で渡されたシート名の存在チェックを行います。
'/*******************************************************************
Public Function isSheetName(SheetName As String) As Boolean

    isSheetName = False
    Dim ws As Worksheet, flag As Boolean
    For Each ws In Worksheets
        If ws.Name = SheetName Then isSheetName = True
    Next ws
End Function

'/*******************************************************************
'/* 引数で渡されたシート名をチェックし、存在しない場合は作成します。
'/*******************************************************************
Public Sub sheetChkMake(SheetName As String)
Dim wk As Object
Dim chkSheetsNm As Boolean

    chkSheetsNm = False
    
    For Each wk In Sheets
        If LCase(SheetName) = LCase(wk.Name) Then
            chkSheetsNm = True
            Exit For
        End If
    Next
    
    'ファイルチェックシートが存在しない場合は新規に作成します。
    If chkSheetsNm = False Then
        Worksheets.Add
        ActiveSheet.Name = SheetName
    Else
        Worksheets(SheetName).Activate
    End If
    
    ActiveSheet.Cells.Clear

End Sub

```