VBA 判断工作簿是否包含公式

1

Option Explicit
'----------------------------------------------------------------------
'MAIN
'----------------------------------------------------------------------
Sub Button1_Click()
    Dim i As Integer
    Dim strInputPath As String
    Dim fileList() As String

    '----------------------------------------------------------------------
    'INPUT PATH
    '----------------------------------------------------------------------
    strInputPath = ThisWorkbook.Sheets("tool").Range("B1").Value
    ThisWorkbook.Sheets("tool").Range("F:H").ClearContents
    
    Application.ScreenUpdating = False
    
    '----------------------------------------------------------------------
    '設計書を取得
    '----------------------------------------------------------------------
    fileList = GetFile(strInputPath)
    
    ThisWorkbook.Sheets("tool").Range("F1").Value = "詳細仕様書名"
    ThisWorkbook.Sheets("tool").Range("G1").Value = "公式有無"
    
    For i = 0 To UBound(fileList)
        If fileList(i) <> "" Then
            ThisWorkbook.Sheets("tool").Range("F" & i + 2).Value = fileList(i)
            ThisWorkbook.Sheets("tool").Range("G" & i + 2).Value = Excel2SQL(strInputPath, fileList(i))
        End If
    Next

    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
    Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
'Get Execl Files List
'----------------------------------------------------------------------
Function GetFile(ByVal strInputPath As String) As String()

    '----------------------------------------------------------------------
    '変数定義
    '----------------------------------------------------------------------
    Dim strFileName As String
    Dim i As Integer
    Dim fileList() As String
    
    '----------------------------------------------------------------------
    '初期化
    '----------------------------------------------------------------------
    i = 0
    strFileName = Dir(strInputPath & "\*設計書*.xlsx")
    
    Do While strFileName <> ""
        ReDim Preserve fileList(i)
        fileList(i) = strFileName
        i = i + 1
        strFileName = Dir
    Loop
    GetFile = fileList
End Function

'----------------------------------------------------------------------
'Exccl To Sql File
'----------------------------------------------------------------------
Function Excel2SQL(ByVal strInputPath As String, ByVal strFile As String)
    
    '----------------------------------------------------------------------
    '変数定義
    '----------------------------------------------------------------------
    Dim objWk As Workbook
    If strFile <> "" Then
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
        Set objWk = Workbooks.Open(strInputPath & "\" & strFile)

        Excel2SQL = ParseDescSQLs(objWk)
        objWk.Close
    End If

End Function

Function ParseDescSQLs(ByRef wk As Workbook)
    On Error GoTo line1
    
    Dim sh As Worksheet
    Dim iRow As Integer
    Dim iCol As Integer
    Dim i As Integer
    Dim j As Integer
    
    For Each sh In wk.Worksheets
        sh.Cells.SpecialCells(xlCellTypeLastCell).Activate
        iRow = Selection.Row
        iCol = Selection.Row

        For i = 1 To iRow
            For j = 1 To iCol
                If sh.Cells(i, j).HasFormula = True Then
                    ParseDescSQLs = "有"
                    Exit Function
                End If
            Next j
        Next i
    Next
line1:
    ParseDescSQLs = "無"
    Resume Next
End Function