Reading Excel file with SQL - Code Improvements needed-CodePudding

I have pulled together some code which works, but I must confess to not understanding the nitty gritty of what its doing and I seem to open two lots of connections, which seems slow and messy, one to get the sheetname which I think I need for the SQL call, and the call itself.

I use it as function but have stripped out to a Sub to try and improve it. It gets used a lot pulling in utility data from up to 700 separate files as part of a process, and running across multiple clients. So if it can be streamlined it will cut time down massively.

The file format varies depending on the task: Alarm Data 51 Columns Wide and either 7 lines or 700 sites *7 lines Meter Data 50 or 99 Columns Wide with a blank column at 51, 15 lines, or up to 700 * 15 lines I can't control the file formats/lengths and don't know the sheetname as it can vary by source

Any help tidying it up is massively appreciated. FootSore

Edit: The files will only ever have one Sheet in them, but name unknown. I only need that sheet.

Function ReadExcelFile(ByRef InputFileArray() As Variant, InputFileName As String, InputFileLocation As String, HeaderYesNo As String)
'Reads Excel File and returns InputFileArray

Dim ReadFileArray() As Variant
Dim connectionString As String
Dim sql As String

    Set FSO = CreateObject("scripting.filesystemobject")
    If FSO.FileExists(InputFileLocation & InputFileName) = True Then
        connectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=""" & InputFileLocation & InputFileName & """;" & _
            "Extended Properties=""Excel 12.0;HDR=" & HeaderYesNo & ";IMEX=1"""
            'This assumes the Excel file contains column headers -- HDR=Yes

        'Routine to get unknown sheet name
        Set conn = CreateObject("ADODB.Connection")
        conn.connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=""" & InputFileLocation & InputFileName & """;" & _
        "Extended Properties=""Excel 12.0;HDR=Yes"""
    
        conn.Open
        Set bs = conn.OpenSchema(20) ' 20 = adSchemaTables
        Do Until bs.EOF = True
            'Debug.Print bs.Fields!Table_Name.Value
            SheetName = bs.Fields!Table_Name.Value
            bs.MoveNext
        Loop
        bs.Close: conn.Close
        Set bs = Nothing
        Set conn = Nothing

        'Get the contents of the Excel via SQL saves opening file
        sql = "SELECT * FROM ["   SheetName   "]" '

        'Go to the VBE's Tools, References then locate and put a check beside 'Microsoft ActiveX Data Objects 6.1 Library' to include the library in your project.
        Dim rs As New ADODB.Recordset
        rs.Open sql, connectionString
        ReadFileArray() = rs.GetRows 'Puts the data from the recordset into an array
        rs.Close
        Set rs = Nothing

        'Debugging Tool
            'Dim row As Variant, column As Variant
            'For row = 0 To UBound(TotalFileArray, 2)
            '    For column = 0 To UBound(InputFileArray, 1)
            '        Debug.Print InputFileArray(column, row)
            '    Next
            'Next

        'Limitations mean the columns and rows are read in wrong order.
        'Public Sub to transpose array
        TransposeArray ReadFileArray, InputFileArray
        Erase ReadFileArray
        
    Else
    End If

End Function

CodePudding user response：

You can re-use the one connection and recordset. Note if your input file has multiple sheets and/or named ranges then this just picks the first one listed.

Also - you're not getting field headers in the returned array.

Sub Tester()
    
    Dim arr
    arr = ReadExcelFile("LookupTable.xlsx", "C:\Temp\", True)
    
    If Not IsEmpty(arr) Then 'read any data?
        Sheet1.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End If
End Sub

Function ReadExcelFile(InputFileName As String, InputFileLocation As String, _
                                                       HeaderYesNo As String) As Variant
    Dim arr As Variant, SheetName As String
    Dim sql As String, conn As Object, rs As Object

    'ideally you do this check *before* calling the function though...
    If Dir(InputFileLocation & InputFileName, vbNormal) = "" Then
        MsgBox "File not found!"
        Exit Function
    End If
    
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=""" & InputFileLocation & InputFileName & """;" & _
        "Extended Properties=""Excel 12.0;HDR=" & HeaderYesNo & ";IMEX=1"""
    
    Set rs = conn.OpenSchema(20) ' 20 = adSchemaTables, NOTE: also reads named ranges...
    If Not rs.EOF Then SheetName = rs.Fields("Table_Name").Value 'Always only one sheet?
    rs.Close
    
    If Len(SheetName) > 0 Then 'got a sheet?
        rs.Open "SELECT * FROM ["   SheetName   "]", conn 're-use connection
        If Not rs.EOF Then ReadExcelFile = TransposeArray(rs.GetRows())
    End If

End Function

Function TransposeArray(arr)
    Dim arrout(), r As Long, c As Long
    ReDim arrout(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For r = LBound(arr, 1) To UBound(arr, 1)
        For c = LBound(arr, 2) To UBound(arr, 2)
            arrout(c, r) = arr(r, c)
        Next c
    Next r
    TransposeArray = arrout
End Function