Writing an Excel range to a csv file: optimisations and unicode compatibility

I posted some VBA code to Split and Join 2D arrays using optimised string-handling a while ago: here's a function using the same logic to write an array to a csv file.

There's some interesting surprises in this kind of simple operation when you meet Unicode characters - and I found out that the horrible hack that I use for reading Excel ranges into complex SQL queries via csv files has some problems when the file contains (say) Arabic company names.

Without going into too much detail, VBA is internally unicode-compliant (strings using 'wide' chars encoding each character in two bytes have been there since well before the turn of the century) but Excel assumes that the outside world runs on ANSI code, or UTF encodings that require a code page. This makes life difficult when you're writing to a file, and reading it again with something else out of Redmond that can manage Unicode text, but hasn't *quite* got it right with the things that other Microsoft products do with this 'We speak Unicode but the outside world is ANSI' thing.

If you do need more detail (and actually, you probably do; there's a lot of misconceptions around and those of us who work in the Microsoft Office 'stack' have some of the most annoying ones), I recommend a quick re-read of Joel Spolsky's blog post: The Absolute Minimum Every Software Developer Absolutely, Positively Must Know About Unicode and Character Sets.

Other stuff: If you call the function repeatedly with the same file name, it'll check that the file's unchanged since the last 'ArrayToCSVfile' write, using an Adler-32 checksum on the file contents. If it's still the same data, it'll bail out. This is *embarrassing* if you're reusing the file name for different data, so be sure to delete the pre-existing files in your calling function if you do that.

And so, without further ado:

Writing an Excel range to a csv file

Public Function ArrayToCSVfile(ByRef InputArray As Variant, _
                               ByVal FilePath As String, _
                               Optional ByVal CoerceText As Boolean = True _
                               ) As Long
                           
' Output an array to a csv file and returns the row count.
' CoerceText=TRUE will encapsulate all items, numeric or not, in quote marks.

' This code handles unicode, and outputs a file that can be read by Microsoft
' ODBC and OLEDB database drivers.

' The first row is assumed to be a list of unique column names. Non-unique or
' blank names are replaced by the F0, F1, F2... sequential names generated by
' widely-used database engines (including MS-Access, JET & OLEDB text drivers)

' Blank rows after the last data row are not written to file.

' The function stores checksums of every file that it writes; we do not over-
' write a pre-existing file if a check on the file name discovers a record in
' the checksum list, and a check on the file contents shows that it still has
' the same checksum. There's an overhead to this preliminary file 'read' of a
' pre-existing file (our VBA implementation of the Adler32 hash can only read
' 25 Mbytes per second) but this is much faster than an uneccessary overwrite

On Error Resume Next

' Coding note: we're not doing any string-handling in VBA.Strings: allocating
' deallocating and (especially!) concatenating are SLOW. We are using the VBA
' Join and Split functions ONLY. Feel free to optimise further by declaring a
' faster set of string functions from the Kernel if you want to.
'
' Other optimisations: type pun. Byte Arrays are interchangeable with strings
' Some of our loops through these arrays have a 'step' of 2. This optimises a
' search-andreplace for ANSI chars in an array of 2-byte unicodes.

' ** THIS CODE IS IN THE PUBLIC DOMAIN **
'   Nigel Heffernan   Excellerando.Blogspot.com

Dim COMMA As String
Dim BLANK As String
Dim EOROW As String
 
 COMMA = ChrW$(44)
 BLANK = ChrW$(13) & ChrW$(10) & ChrW$(13) & ChrW$(10)
 EOROW = ChrW$(13) & ChrW$(10)
 
 
Dim i As Long
Dim j As Long
Dim k As Long

Dim i_LBound As Long
Dim i_UBound As Long
Dim j_LBound As Long
Dim j_UBound As Long
Dim k_lBound As Long
Dim k_uBound As Long

Dim iCheckSum  As Long
Dim iRowCount  As Long
Dim hndFile    As Long
Dim arrBytes() As Byte
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim arrTemp3(0 To 2) As String

Dim strBlankRow As String
Dim boolSkipRow As Boolean
Dim boolNumeric As Boolean

Dim strHeader   As String
Dim arrHeader() As Byte


Static FileCheckSums As Scripting.Dictionary
If FileCheckSums Is Nothing Then
    Set FileCheckSums = New Scripting.Dictionary
End If

If Len(VBA.FileSystem.Dir(FilePath)) <> 0 Then
    iCheckSum = FileCheckSum(FilePath)
    If FileCheckSums(FilePath) = iCheckSum Then
        ArrayToCSVfile = -1
        Exit Function ' The file's unchanged since we last created it.
    Else
        VBA.FileSystem.Kill FilePath
    End If
End If


i_LBound = LBound(InputArray, 1)
i_UBound = UBound(InputArray, 1)

j_LBound = LBound(InputArray, 2)
j_UBound = UBound(InputArray, 2)

ReDim arrTemp1(i_LBound To i_UBound)
ReDim arrTemp2(j_LBound To j_UBound)

' We start with a 2-byte 'Wide' char. This coerces all subsequent operations to unicode

arrTemp3(0) = ChrW$(34)       ' Encapsulating quote
arrTemp3(1) = vbNullString    ' The field value will go here
arrTemp3(2) = ChrW$(34)       ' Encapsulating quote


' Special handling for the header row. Not optimised, but it's only one row
i = i_LBound

    For j = j_LBound To j_UBound
    
        arrTemp3(1) = ChrW(70) & j ' Columns must have a unique header. Default F0, F1...
        
        If IsError(InputArray(i, j)) Then
            ' no action
        ElseIf IsNull(InputArray(i, j)) Then
            ' no action
        ElseIf IsEmpty(InputArray(i, j)) Then
            ' no action
        ElseIf Len(InputArray(i, j)) = 0 Then
            ' no action
        Else
            If IsDate(InputArray(i, j)) Then
                 arrTemp3(1) = Round(CDbl(CVDate(InputArray(i, j))), 8)
            Else
                
                arrBytes = CStr(InputArray(i, j))
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    Select Case arrBytes(k)
                    Case 10, 13, 9, 44, 160 ' replaces CR, LF, Tab, Comma, and non-breaking
                        arrBytes(k) = 32    ' spaces with the standard ANSI space character
                    Case 34
                        arrBytes(k) = 39
                    End Select
                Next k
                arrTemp3(1) = arrBytes
            End If
        End If
       
        arrTemp2(j) = Join(arrTemp3, vbNullString)
        
        ' Remove duplicated field names
        For k = j_LBound To j - 1 Step 1
            If StrComp(arrTemp2(k), arrTemp2(j), vbTextCompare) = 0 Then
                arrTemp2(j) = ChrW(34) & "F" & j & ChrW(34) ' Non-unique: revert to default
                Exit For
            End If
        Next k
        
    Next j
    
    arrTemp1(i) = Join(arrTemp2, COMMA)



' Data body. This is heavily optimised to avoid VBA.String functions with allocations
For i = 1 + i_LBound To i_UBound

    boolSkipRow = True
    For j = j_LBound To j_UBound
    
    If IsEmpty(InputArray(i, j)) Then 'This condition is so common that we separate it out into its
        arrTemp2(j) = vbNullString    'own IF...THEN clause & subordinate the rest into nested IFs
    Else
        If IsError(InputArray(i, j)) Then
            arrTemp2(j) = vbNullString    '' was #ERROR
        ElseIf IsNull(InputArray(i, j)) Then
            arrTemp2(j) = vbNullString
        ElseIf Len(InputArray(i, j)) = 0 Then
            arrTemp2(j) = vbNullString
        Else
            boolSkipRow = False                 ' This is definitely a non-blank row
            If IsDate(InputArray(i, j)) Then
                 arrTemp2(j) = InputArray(i, j) ' Safer to Round(CDbl(CVDate(InputArray(i, j))), 8)
                                                ' but that's costly for performance. You are better
                                                ' off trusting Range.Value2 to create input arrays.
            Else
                arrBytes = CStr(InputArray(i, j))
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    Select Case arrBytes(k)
                    Case 10, 13, 9, 44, 160    ' replace CR, LF, Tab, Comma,   with space
                        If arrBytes(k + 1) = 0 Then arrBytes(k) = 32
                    Case 34
                        If arrBytes(k + 1) = 0 Then arrBytes(k) = 39
                    End Select
                Next k
                arrTemp2(j) = arrBytes
                arrBytes = vbNullString
            End If
        End If
    End If ' isempty
    Next j
    
    If boolSkipRow Then
        arrTemp1(i) = vbNullString
        iRowCount = iRowCount - 1
    Else
    
        If CoerceText Then  ' encapsulate all fields in quotes
        
            For j = j_LBound To j_UBound
                arrTemp3(1) = arrTemp2(j)
                arrTemp2(j) = Join$(arrTemp3, vbNullString)
            Next j
            
        Else
            
            For j = j_LBound To j_UBound
            
                arrBytes = arrTemp2(j)
                boolNumeric = True
                
                For k = LBound(arrBytes) To UBound(arrBytes) Step 2
                    If arrBytes(k) < 45 Or arrBytes(k) > 57 Then
                        boolNumeric = False
                        Exit For
                    End If
                Next k
                
                If boolNumeric Then
                    For k = 1 + LBound(arrBytes) To UBound(arrBytes) Step 2
                        If arrBytes(k) <> 0 Then
                            boolNumeric = False
                            Exit For
                        End If
                    Next k
                End If
                
                arrBytes = vbNullString
                
                If Not boolNumeric Then
                    arrTemp3(1) = arrTemp2(j)
                    arrTemp2(j) = Join(arrTemp3, vbNullString)
                End If
                
            Next j
            
        End If
     
        arrTemp1(i) = Join(arrTemp2, COMMA)
     
     End If
    
Next i

iRowCount = i + iRowCount - 2
If iRowCount < 1 Then
    iRowCount = 0    ' Note: this count excludes the header
End If
    


'   ****   WHY THIS IS COMMENTED OUT   **** **** **** **** **** **** **** ****
'
'   Microsoft ODBC and OLEDB database drivers cannot read the field names from
'   the header when a unicode byte order mark (&HFF & &HFE) is inserted at the
'   start of the text by Scripting.FileSystemObject 'Write' methods. Trying to
'   work around this by writing byte arrays will fail; FSO 'Write' detects the
'   string encoding automatically, and won't let you hack around it by writing
'   the header as UTF-8 (or 'Narrow' string) and appending the rest as unicode
'
'   (Yes, I tried some revolting hacks to get around it: don't *ever* do that)
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
'
'    With FSO.OpenTextFile(FilePath, ForWriting, True, TristateTrue)
'        .Write Join(arrTemp1, EOROW)
'        .Close
'    End With ' textstream object from objFSO.OpenTextFile
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
    



'   **** WHY WE 'PUT' A BYTE ARRAY INSTEAD OF A VBA STRING VARIABLE  **** ****
'
'       Put #hndFile, , StrConv(Join(arrTemp1, EOROW), vbUnicode)
'       Put #hndFile, , Join(arrTemp1, EOROW)
'
'   If you pass unicode, Wide or UTF-16 string variables to PUT, it prepends a
'   Unicode Byte Order Mark to the data which, when written to your file, will
'   render the field names illegible to Microsoft's JET ODBC and ACE-OLEDB SQL
'   drivers (which can actually read unicode field names, if the helpful label
'   isn't in the way). However, the 'PUT' statements write a Byte array as-is.
'
'   **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
    
    
    
    arrBytes = Join(arrTemp1, EOROW)
    
    ' Remove empty rows after the data: this is so common in arrays from Excel
    ' ranges that the performance penalty is acceptable (one big allocation in
    ' the Redim Preserve statement) but you may prefer to comment out the code
    
    ' We *could* do a Replace on BLANK to get internal blank rows as well, but
    ' I don't trust the unicode handling and the performance penalty is higher
    
    k_lBound = LBound(arrBytes)
    k_uBound = UBound(arrBytes)
    For k = k_uBound - 1 To k_lBound Step -1
        If arrBytes(k) <> 0 Then
            If Not (arrBytes(k) = 10 Or arrBytes(k) = 13) Then
                Exit For
            End If
        End If
    Next k
    ReDim Preserve arrBytes(k_lBound To k + 1)
    
    hndFile = FreeFile
    Open FilePath For Binary As #hndFile
    
    Put #hndFile, , arrBytes
    Close #hndFile
    
    FileCheckSums(FilePath) = StringCheckSum(arrBytes)
    
    Erase arrBytes
    

    ArrayToCSVfile = iRowCount


ExitSub:
On Error Resume Next
    
    Erase arrTemp1
    Erase arrTemp2
    Exit Function
    
ErrSub:
    Resume ExitSub
  
  
  
End Function

You'll need this, too: the file and string checksum functions called in the code.

A VBA implementation of the Adler-32 checksum, running on byte arrays instead of using VBA string-handling.

This includes another Heffernan Horrible Hack: the VBA Long Integer data type doesn't go up tp 2³², it's a signed integer for ±2³¹. So there's a wraparound at 2³¹-1, which feels rather quaint in this modern age of 64-bit LongLong integers.

However, there is old-worlde quaintness, and there's mediæval barbarism: the final operation of an Adler-32 hashing function is a multiplication that can and does blow past 2³², and I'm using a Floating-point double to do it. If my castle is ever threatened by a mob of peasants with pitchforks and torches, I might encapsulate that in a conditional-compilation block on #VBA7, with a proper LongLong integer in the 64-bit block and the barbarism confined to the #Else block.

Public Function StringCheckSum(ByRef ByteArray() As Byte) As Long
Application.Volatile False

' Returns an Adler32 checksum of a string: typically a large file's contents

' Note that the VBA Long Integer data type is *not* a 32-bit integer, it's a
' signed integer with a range of  ± (2^31) -1. So our return value is signed
' and return values exceeding +2^31 -1 'wraparound' and restart at -2^31 +1.

' Test your results. Some data sets (especially repeating dates) have double
' digit collision rates, and you'll need to find a different hash algorithm.


' Coding Notes:

' What, didn't you know that a Byte Array and a string are type-compatible?

' This is intended for use in VBA, and not for use on the worksheet. Use the
' setting  'Option Private Module' to hide CheckSum from the function wizard


' Author: Nigel Heffernan, May 2006  http://excellerando.blogspot.com
' Acknowledgements and thanks to Paul Crowley, who recommended Adler-32

'  Please note that this code is in the public domain. Mark it clearly, with
'  the author's name, and segregate it from any proprietary code if you need
'  to assert ownership & commercial confidentiality on your proprietary code



Const LONG_LIMIT As Long = (2 ^ 31) - 1
Const MOD_ADLER As Long = 65521

Dim a As Long
Dim b As Long
Dim i As Long


Dim dblOverflow As Double

Dim i_LBound As Long
Dim i_UBound As Long

a = 1
b = 0

i_LBound = LBound(ByteArray)
i_UBound = UBound(ByteArray)

    For i = i_LBound To i_UBound
        
        a = (a + ByteArray(i)) Mod MOD_ADLER
        b = (b + a) Mod MOD_ADLER
 
    Next i
    
' Using a float in an integer calculation? We can get away with it, because
' the float error for a VBA double is < ±0.5 with numbers smaller than 2^32

dblOverflow = (1# * b * MOD_ADLER) + a

If dblOverflow > LONG_LIMIT Then  ' wraparound 2^31 to 1-(2^31)
   
    Do Until dblOverflow < LONG_LIMIT
        dblOverflow = dblOverflow - LONG_LIMIT
    Loop
    StringCheckSum = 1 + dblOverflow - LONG_LIMIT
    
Else
    StringCheckSum = b * MOD_ADLER + a
End If


End Function


Public Function FileCheckSum(strFilePath As String) As Long
Application.Volatile False
On Error Resume Next


'Return an ADLER-32 checksum from a file

' Throttle repeated calls using static variables. WARNING
' this assumes the file hasn't changed in the last 500 ms

    Static LastFile As String
    Static LastCall As Single
    Static LastHash As Long
    
    If LastFile = strFilePath Then
        If VBA.Timer - LastCall < 0.5 Then
            FileCheckSum = LastHash
            Exit Function
        Else
            LastCall = VBA.Timer
        End If
    Else
        LastFile = strFilePath
        LastCall = VBA.Timer
    End If


Dim hndFile As Long
Dim arrBytes() As Byte
Dim lenData As Long


hndFile = FreeFile
Open strFilePath For Binary As #hndFile

ReDim arrBytes(0 To LOF(hndFile) - 1)
Get #hndFile, , arrBytes
Close #hndFile

FileCheckSum = StringCheckSum(arrBytes)

Erase arrBytes

LastHash = FileCheckSum

End Function

Share and enjoy.

I should thank the estimable Paul Crowley for showing me the Adler-32 algorith, years ago, and much else besides; but a gentleman aficionado of algrorithmic elegance might prefer to dissociate himself from such abuses.

In the absence of interesting content, a filler piece

We don't always get to write good code: sometimes we have the job of thanking someone for their contribution, telling them truthfully and cheerfully: "No, really: it couldn't *possibly* be improved!", and gaffer-taping it together with comprehensible variable declarations and a bit of code-readability work.

Here's a function that will help you with that:

'
Public Function f(Optional Filler As Variant = "") As Double
Application.Volatile False

' Function always returns zero - its only purpose is to 'pad out' expressions for readability
' An option to suppress VBA's habit of excising 'unnecessary' whitespace would be more useful

f = 0

' Coding Notes:
'
' If it is ever necessary for you to use this, leave the following note for your colleagues:
'
'          "There is no hope for us. I am Bricking Up The House From Within."
'
' Code Enhancement: leave an acknowledgement in the code, naming someone you *really* dislike

End Function

Feel free to *not* acknowledge my contribution if you reuse this code.

I do have an acknowledgement for my betters here: the apocalyptic phrase 'We Are Bricking Up The House From Within' originates from Adrian Bott, well known and much-esteemed as @Cavalorn.

He's not a developer: he's a published author of Fantasy and Horror.

What's the most useful answer you've ever given?

Last time I looked at Stack Overflow, the most useful answer - or rather, the most read-and-endorsed answer - I've ever given was to a question about copyright notices.

Maybe I'm in the wrong job, and there's better living to be made as an attorney (a Solicitor in England) than being a spreadsheet-basher.

Anyway, the question (and my answer to it) was deleted long ago, so I'll put it here for posterity:

Do you put copyright notices in your (proprietary) code?

The better-organised companies have a copyright notice, pre-generated and added automatically to the header of every code module.

If your employer isn't sufficiently clued-up to ask you, don't bother asking them. It'll be seen as troublemaking, and you'll be blamed for something - anything! - and everything.

Yes, big companies really do think that way.

Meanwhile, put a friendly notice into your code modules and classes to help more junior developers, who might not be aware that (say) code you copied off MSDN or an API published on the web (or some friendly blogger) is almost certainly encumbered with a GPL or CopyLeft License:

' Nigel Heffernan, [xxx dept, xxxyyy company, London] October 2009

' This code is adapted from material in the Public Domain
'  (April 2009  Excellerando.Blogspot.com).
'
' It is unencumbered by copyrights and patents and we can use it freely,
' but we can only assert our own Intellectual Property rights on derived
' works: the original work remains free for public use.
'
' If you contribute distinctive features and original concepts, take care
' to segregate your source code and clearly mark it with our registered 
' company name and a link to our copyright license warning.

There is, of course, the old standby:

 If you were thinking of making an unauthorised copy and using it outside the company, don't.

    We have a dimly-lit bunker, deep underground, with row upon row of incubation tanks,
    each one holding an Intellectual Property Lawyer in a nutrient solution of neurotoxic
    venom and the even-numbered isotopes of plutonium that no-one wanted to use in their
    nuclear weapons. If you use this software without authorisation, we will decant them
    off, one a day, every day, and let them loose with an  unlimited  legal budget until 
    you are nothing but a radioactive hole in the ground surrounded by safety warnings 
    and foreclosure notices. 

 Also, the moment when they open their eyes and stare at you is CREEPY.

I believe there is a older version by Neil Gaiman (a fantasy author, not a coder) with something about bat-winged horrors of the outer darkness.

I worry that mentioning 'Plutonium' has put me on some kind of watchlist, and someday it's going to be difficult to board airliners. But that's all just fine: we're all so much safer because of it, and you're probably on a list too, just for reading this page.

Let me know if you get targeted advertising offering to sell you any, its *really* unfair on the delivery guy.

A Horrible Hack: Complex SQL Queries on Excel Data

A Cautionary Tale of things that no developer should ever see or do, with diversions and digressions into failures of business logic, workarounds and worse-arounds, budget fairies, business analysts, and scrofulous pilgrims seeking miraculous healing in the elevator lobby.

From time to time it necessary to perform a Horrible Hack. A hack that might have tolerable snippets of code, or even pretty nifty ones; but it's a Horrible Hack if the whole thing, taken as a whole, ought to be buried in a hole - and this post show you the code for one of them.

The task is deceptively simple: perform SQL queries on data sets that happens to be in Excel. Because vlookup can only do so much, and Pivot tables aren't flexible enough, and WHY AREN'T YOU DOING THIS IN A PROPER DATABASE INSTEAD OF KLUDGING?

Well, the answer to that is: "It's a prototype, and it's on the stack for the database developers to get it done properly". Except that it's still running in Excel, a year or so later, and the database guys aren't going to touch it. Ever. Because the SQL is too complex for them, or it wasn't invented here, or maybe you don't have the staffing budget for human sacrifice or whatever propitiates the wrath of database administrators.

Other reasons: the data for our report exists in multiple systems, not all of them expose a SQL interface, and the *only* export format that they have in common in they can spit out .xls files. And some of the config data (exception lists) only exists in an Excel sheet on a Sharepoint server. Yes, we'd like that to live in a proper table in a named application with a relational database: and no, nobody's going to build it. Ever. Not 'til Hell freezes over and the magic budget fairy brings you a dedicated infrastructure spend and three business analysts bearing gold, detailed system specifications, and signoff from managers so senior that queues of pilgrims wait outside the executive elevator lobby, hoping for the chance to touch the hem of their suits and cure themselves of scrofula.

And this is where Horrible Hacks come from, on the user side: business requirements that emerge from a need to work around blockages and other anomalies in the business processes we serve in our software.

But to be truly horrible, a Horrible Hack needs an additional layer of complexity arising from the need to work around a fundamental failure in the technical platform. And yes, we have *just* the thing: Microsoft's SQL drivers for Excel are unstable. You can't just connect to an Excel workbook - closed or open - with an OLEDB session using the publicly-available Excel driver; nor can you do so with ODBC ISAM drivers - they all have memory leaks, and they will all crash the host application if you run them often enough. So Excel data isn't directly available to complex SQL.

So... How bad can it get?

Well, we start by grabbing the data from closed workbooks using SQL sent to the Excel OLEDB driver. We can *just* get away with it by closing the connections immediately. If I was paranoid, I'd run this in 'shelled' separate sessions of Excel.exe - but that really is too much work for an app that's going to be replaced by the grown-ups in a proper Dev team, right?

We save that data as text files in a temporary folder.

And read those files, just as if they were tables in a database, using SQL and the Microsoft Jet Text OLEDB driver.

Yes, you heard that correctly: we're using JET SQL. It's a peculiar dialect of SQL... And if you want to get clever with the data-grabbing phase, and filter the data you grab from the source range, you'll need to know the arcane conventions for naming the 'table' in your query with a '$' depending on whether it's a named range or a sheet, or a range address. Oh, and bracketing it. Mustn't forget bracketing.

But once we get beyond that, and you're just querying the 'tables' you've created in that temp folder, it's actually pretty straightforward. Unions, joins, aliasing tables into subqueries, conditional logic (IF statements, JET SQL doesn't support CASE): the whole of SQL is there for you.

Excel is actually a pretty good SQL editor - if you have a well-written text-grabber to read the range you're writing SQL in - because moving blocks of text around and marking-up with background shading is really, really easy. And the smart kids will have a range marked up as 'Test SQL' with a 'GetRecordset' function behind the 'Test It!' button that returns the full error strings from the database engine, which includes the syntax errors and line numbers.

Oh, and you can use Excel Formulas to feed in parameters, especially start and end dates: my advice is 'Be sparing with that', but it's just too damned convenient. I would suggest formatting any text that does that in red, just so that you know. I would also recommend casting your dates to doubles, and be *very* defensive about nulls and type errors.

Here's what I mean by 'defensive': a sample of a straightforward JET SQL query with embedded dates from Excel formulae...

SELECT     
    [Workbook Group],     
    IIF( [Region] IS NULL, '', [Region]) AS [Region],     
    IIF([File ID] IS NULL, 0, CDBL([File ID])) AS [File ID],    
    [File Name],     
    IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint]))           ) AS [EventTime],       
    IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (5/24)) AS [EventTimePlusNA],        
    IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (4/24)) AS [EventTimePlusNA1],    
    IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) - (7/24)) AS [EventTimeMinusAsia],       
    [Reason],     
    [Owner],     
    CDBL(CDATE([Expiry])) AS [Expiry],    
    [Standard Reason]    
FROM      
(   
        SELECT *   
        FROM  [Signoff Exceptions$]    
        WHERE [File ID] IS NOT NULL  
          AND [Expiry] IS NOT NULL  
          AND [Reason] IS NOT NULL  
          AND [Owner] IS NOT NULL  
          AND (  
                   (ISDATE([Timepoint])  AND   AND   AND   AND  AND NOT ([Timepoint] IS NULL OR [Timepoint] = 0 ))  
                OR ([Standard Reason] LIKE 'No Reportable%' AND ([Timepoint] IS NULL OR [Timepoint] = 0 OR [Timepoint] LIKE 'ALL'  OR [Timepoint] ='' ))  
              )  
)       AS tFile  
WHERE   
(    [TimePoint] IS NULL   
 OR IIF(ISDATE([TimePoint]),      
        (    CDBL(CDATE([Timepoint]))  >= CDBL(CDATE(41595))     
         AND CDBL(CDATE([Timepoint]))  <= CDBL(CDATE(41622))    
         ),    
        FALSE    
       )   
)   
AND   
(   
     IIF(ISDATE([Expiry]), CDBL(CDATE([Expiry])) >= CDBL(CDATE(41900)), TRUE)    
)   
AND [File ID] IS NOT NULL

Alert readers will spot the '$' dollar sign on the table name. Yes, this is a SQL query sent to the data grabber, filtering the data before we save it to a .csv text file in the 'database' folder with the other 'tables'. We could've just sent the range name 'Signoff Exceptions$' directly to the data grabber:

    arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)

As opposed to:

    arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)

The real SQL - actually querying the tables we've created - can be as simple as you like:

SELECT     
    IIF(tP.[File ID] IS NULL, '(Unknown)', tP.[Workbook Group]) AS [Workbook Group],     
    IIF(tP.[File ID] IS NULL, '*WARNING* FILE ID ' & tX.[File ID] & ' NOT FOUND ', '') &  tX.[File Name] AS [File Name],     
    tX.[File ID],     
    tX.[Region],     
 
    IIF(tX.[EventTime] IS NULL,  'ALL',     
            CDBL( CDATE(tX.[EventTime]) )    
       ) AS [Event Time],     
 
    tX.[Reason],     
    tX.[Owner],     
    IIF(tX.[Expiry] IS NULL, NULL, CDBL(CDATE(tX.[Expiry]))) AS [Exemption Expiry],     
    [Standard Reason]    
  
FROM       
    (SELECT * FROM [tblExemptions.csv] WHERE  [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL  ) AS tX     
    LEFT JOIN  (SELECT * FROM [tblPatterns.csv] WHERE  [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL  ) AS tP    
           ON tX.[File ID] = tP.[File ID]    
  
WHERE    
    tX.[Standard Reason] NOT LIKE 'No Reportable%'
 
ORDER BY 
    tP.[Workbook Group],     
    tX.[File Name],     
    IIF(tX.[Expiry] IS NULL, NULL, CDATE(tX.[Expiry])) 

The SQL can also be as complicated as you like, and that's what this is all about: we're doing data queries in SQL because the logic we need to implement is far, far too complex for the user tools provided in a desktop application. Excel's good, and pivoting is remarkably good, but it's good for tasks within the reach of people without formal training in structured data.

Which brings us to the next part: presentation and the User Experience...

One thing you won't see here, because I'm only posting the code, is Rule 1 of Horrible Hacks: Horrible under the surface, but a clean, crisp, beautiful interface. The uglier your plumbing, the prettier the faucets, the basin and the bidet... And *this* one went out with the interface design equivalent of gold-plated crystal faucets and a four-piece chamber orchestra playing for you as the Personal Assistant checks the loofah for *exactly* the right degree of scratchiness while running the bath to the perfect temperature.

OK. Lets get started.There's a big red button and all it does is call 'Grab the data' and 'Run the reports':

Public Sub RunReports()

    FetchSourceData

    SignoffTimestamp
    ReportAcceptances
    ReportExemptions
    ReportSignoffsALL
    ReportSummary

    ThisWorkbook.Names("Report_TimezoneDescription").RefersToRange.Value = "All timestamps are " & TimeZone
    ThisWorkbook.Names("Datestamp_LastRun").RefersToRange.Value = Now()

    Application.Calculate

End Sub

Not very informative... But the point is, we try and keep individual functions simple. And we segregate our code: this is from the application's custom module - the reports are in here, as is FetchSourceData (the 'grabber) because they're all custom code for this specific app.

There's a separate module called 'basExcelSQL', and that contains all the generic SQL-reading and ADODB-connecting code that gets reused whenever I have to try this stunt again. And yes, I do, and did.

SO lets look at the 'report' functions, using the Exemptions report as a sample:

Public Sub ReportExemptions()
Application.StatusBar = "Exemptions report..."

Dim SQL As String
Dim rst As ADODB.Recordset
Dim rng As Excel.Range
Dim j As Integer
Dim strSource As String

Set rng = ThisWorkbook.Names("Report_Exempted").RefersToRange
SQL = ReadRangeSQL(ThisWorkbook.Names("SQL_Exemption_List").RefersToRange)


rng.ClearContents
Set rst = FetchRecordset(SQL)

If rst Is Nothing Then
    Exit Sub
End If

If rst.State <> 1 Then
    Exit Sub
End If


' Write out the column headings
For j = 0 To rst.Fields.Count - 1
    rng.Cells(1, j + 1) = rst.Fields(j).Name
Next j

If Not (rst.EOF And rst.BOF) Then
    ArrayToRange rng.Cells(2, 1), ArrayTranspose(rst.GetRows)
    rng.AutoFilter
End If

rst.Close
rst.ActiveConnection.Close
Set rst = Nothing

Application.StatusBar = False
End Sub

Yes, I could parameterise it: and no, I didn't. All of the individual report functions look like this, because they all ended up getting customised - it's what this module's for, custom code - and this one got an extra function to diplay a timestamp and time-of-file in the report header, with a checked and updated hyperlink to the source file on the SharePoint folder. Other reports got custom formatting, special headers, and so on.

We'll be looking at ReadRangeSQL and FetchRecordset later, with the rest of the 'basExcelSQL' module; the point here is that we have clean code on top of the Horrible Hack, and less-confident developers can easily reuse your code.

So what does 'FetchSourceData' do? Well, it reads a table - not in SQL this time, we've got to start somewhere, so this is an Excel Range on a sheet called 'Settings' - listing the folders and the files...

...EXCEPT that we're reading files dumped in folders by server-based applications, with date strings in the names. So we can look for a literal file name, or look for a wildcard search string, and pick out the most recently-saved file.

Public Sub FetchSourceData()
Application.StatusBar = "Fetching source data..."

' Read each file in the 'TableNames' range into a local table

' In more detail:

' 1: If a pattern (wildcard '*') is used, use the most recent matching file
' 2: Write the data to a properly formatted csv file in a local temp folder
' 3: These named csv files are visible to the Microsoft Text ISAM as tables
'    in a 'database' (the folder containing them) which supports MS JET SQL

Dim strSourceFolder As String
Dim strSourceFile   As String
Dim strTable        As String
Dim strRange        As String
Dim dblLastImport   As Double
Dim strFieldNames   As String

Dim arrTables       As Variant
Dim iRow            As Integer
Dim varData         As Variant
Dim strFilePath     As String
Dim dblFileDate     As Double
Dim maxFileDate     As Double

Dim strFoundFile    As String
Dim strUseFile      As String


SheetSettings.Calculate


strSourceFolder = ThisWorkbook.Names("SourceFolder").RefersToRange.Value2

If InStr(1, strSourceFolder, "//") > 0 Then
    If Right(strSourceFolder, 1) <> "/" Then
        strSourceFolder = strSourceFolder & "/"
    End If
Else
    If Right(strSourceFolder, 1) <> "\" Then
        strSourceFolder = strSourceFolder & "\"
    End If
End If

' Parse out web folder paths

If Left(strSourceFolder, 5) = "http:" Then

    strSourceFolder = Right(strSourceFolder, Len(strSourceFolder) - 5)
    strSourceFolder = Replace(strSourceFolder, "%20", " ")
    strSourceFolder = Replace(strSourceFolder, "%160", " ")
    strSourceFolder = Replace(strSourceFolder, "/", "\")

End If


Application.StatusBar = "Fetching source data"

' Column 1: strTable  = arrTables(iRow, 1)  - the table name (csv filename) in the 'database' temp folder
' Column 2: strRange  = arrTables(iRow, 2)  - The range address, or a SQL string reading and filtering the range
' Column 3: strSource = arrTables(iRow, 3)  - The file ( a literal name or a wildcard search term )
' The other columns are datestamps and status / error information

arrTables = ThisWorkbook.Names("TableNames").RefersToRange.Value2

For iRow = LBound(arrTables, 1) + 1 To UBound(arrTables, 1)

    
    Application.StatusBar = "Fetching source data" & String((iRow Mod 3) + 1, ".")

    strTable = ""
    strTable = arrTables(iRow, 1)
    
        If strTable <> "" Then
        If IsError(arrTables(iRow, 2)) Then
            arrTables(iRow, 2) = "#ERROR"
        End If
        strRange = arrTables(iRow, 2)
        strSourceFile = arrTables(iRow, 3)
        
        If IsDate(arrTables(iRow, 4)) Then
            dblLastImport = arrTables(iRow, 4)
        Else
            dblLastImport = 0
        End If
        
        strFilePath = strSourceFolder & strSourceFile
        
        
        If InStr(strSourceFile, "*") Then
        
          ' Identify the most recent file matching the pattern given in the TableNames list
            maxFileDate = 0
            strUseFile = ""
            strFoundFile = ""
            On Error GoTo ErrFolder
            strFoundFile = Dir(strSourceFolder & strSourceFile)
            
            On Error GoTo ErrSkipFile
            Do While Len(strFoundFile) > 0
                
                dblFileDate = 0
                dblFileDate = VBA.FileSystem.FileDateTime(strSourceFolder & strFoundFile)
                If dblFileDate > maxFileDate Then
                
                    strUseFile = strFoundFile
                    maxFileDate = dblFileDate
                    
                End If
                
            strFoundFile = Dir
            Loop
            
            If Len(strUseFile) > 0 Then
                strFilePath = strSourceFolder & strUseFile
                ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 5) = strUseFile
            End If
            
        End If
        
        On Error GoTo ErrFile
        If Len(Dir(strFilePath)) = 0 Then
        
            If Len(Dir(Folder(strSourceFolder), vbDirectory)) = 0 Then
                Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because " & APP_NAME & " cannot find the data folder: " & vbCrLf & vbCrLf & "'" & Folder(strSourceFolder) & "'" & vbCrLf & vbCrLf & "Please use Windows Explorer to check that the folder exists, and check that you have permission to open files in it."
            End If
            
            Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because there is no file matching '" & strSourceFile & "' in this location: " & vbCrLf & vbCrLf & strFilePath & vbCrLf & vbCrLf & "Please open the folder and make sure that the source files for the report are in place."
            
        End If
        
        On Error GoTo ErrSub
        
        ' Record the datestamp of the file we've selected for loading
        ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 6) = VBA.FileSystem.FileDateTime(strFilePath)
        
        strFieldNames = ""
        
        ' read the data from the file
        varData = GetDataFromClosedWorkbook(strFilePath, strRange, strFieldNames, True)
        
        If IsEmpty(varData) Then
        
            ArrayToFile varData, strTable, True, strFieldNames
            ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = "#NO DATA RETURNED BY THE QUERY"
            
        ElseIf IsArray(varData) Then
        
            ' write the data to a properly formatted csv file in a local temp folder
            ArrayToFile varData, strTable, True, strFieldNames
            ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = Now()
            Erase varData
            varData = Empty
        Else
        
            ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = varData
            varData = Empty
            
        End If 'IsEmpty(varData) Then
    
    
    End If ' strTable <> ""
    
Next iRow



Erase arrTables

ExitSub:

    Application.StatusBar = False
    Exit Sub
    
ErrSub:

    Select Case MsgBox(Err.Description, vbCritical + vbAbortRetryIgnore + vbMsgBoxHelpButton, APP_NAME & ": Error fetching source data", Err.HelpFile, Err.HelpContext)
    Case vbRetry
        Resume
    Case vbIgnore
        Resume Next
    Case vbAbort
        End
    Case Else
        ' undefined behaviour from 'Escape'
        End
    End Select
    
    Resume ExitSub

ErrFile:
    
    MsgBox Err.Description, vbApplicationModal, "Signoff Progress Report: missing data file"
    'This error is fatal - bad file! - and we will halt execution.
    End
    
ErrFolder:
    MsgBox "Cannot retrieve file data from the following folder: " & vbCrLf & vbCrLf & strSourceFolder & vbCrLf & vbCrLf & "Windows returned the following error: ERROR " & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & "Check the folder in Windows Explorer, as the problem may be your access privileges.", vbCritical + vbMsgBoxHelpButton, APP_NAME & ": inaccessible data folder", Err.HelpFile, Err.HelpContext
    'This error is fatal - bad data folder! - and we will halt execution.
    End

ErrSkipFile:
    ' called from resilient code - we're scanning files in a folder, if it's unusable we'll just try the next file
    Resume Next
    
End Sub

Public Function FilePath(strSharePointPath As String) As String
Application.Volatile False
' Translate sharepoint paths into their underlying filesystem addresses

FilePath = strSharePointPath
If Left(FilePath, 5) = "http:" Then

    FilePath = Right(FilePath, Len(FilePath) - 5)
    FilePath = Replace(FilePath, "%20", " ")
    FilePath = Replace(FilePath, "%160", " ")
    FilePath = Replace(FilePath, "/", "\")

End If

End Function

Really, it's just a wrapper feeding parameters into GetDataFromClosedWorkbook, which reads data directly from Excel ranges, and for the ArrayToFile function which writes the extracted data into our 'table' files.

WHich is to say: there is one complicated operation in there - reading and checking filenames out of a table - and the other operations are in clearly-named functions. Indirection, we call it.

And so, without further ado (or ADODB), we reveal the code that does the heavy lifting, basExcelSQL:

Option Explicit
Option Private Module

' ADODB data retrieval functions to support SQL queries against
' Excel data in the current workbook, and in closed workbooks

' Online reference for connection strings:
' http://www.connectionstrings.com/oracle#p15

' Online reference for ADO objects & properties:
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx


Private m_objFSO        As Object ' Scripting.FileSystemObject
Private m_strTempFolder As String

Private m_objConnText   As ADODB.Connection
Private m_strConnText    As String


Private Property Get objFSO() As Object
' Return a File System Object
On Error Resume Next

If m_objFSO Is Nothing Then
    Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If

If m_objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Set m_objFSO = CreateObject("Scripting.FileSystemObject")
End If

Set objFSO = m_objFSO

End Property


Private Property Get TempSQLFolder() As String
    
    m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath     ' Scripting.TemporaryFolder
    
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If
    
    m_strTempFolder = m_strTempFolder & "XLSQL"
    
    If Not objFSO.FolderExists(m_strTempFolder) Then
        objFSO.CreateFolder m_strTempFolder
    End If
        
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If
    
    TempSQLFolder = m_strTempFolder
    
End Property


Private Property Get connText() As ADODB.Connection
On Error Resume Next

' The Excel database drivers have problems when multiple instances of the Excel application
' are running, so we use a text driver to read csv files in a temporary folder. These files
' are populated from ranges specified for use as tables by the FetchXLRecordSet() function.
    
    
If objFSO Is Nothing Then
    Exit Property
End If


On Error GoTo ErrSub

Set m_objConnText = New ADODB.Connection


    ' Specify and clear a temporary folder:
    
    m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath     ' Scripting.TemporaryFolder
    
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If
    
    m_strTempFolder = m_strTempFolder & "XLSQL"
    
    Application.DisplayAlerts = False

    
    If Not objFSO.FolderExists(m_strTempFolder) Then
        objFSO.CreateFolder m_strTempFolder
    End If
        
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If

       
    
' JET OLEDB text driver connection string:
'   Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited;MaxScanRows=;IMEX=1;";

' ODBC text driver connection string:
'   Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;


    m_strConnText = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";"
    m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
    
  ' SetTypeGuessRows
    With m_objConnText

        .CursorLocation = adUseClient
        .CommandTimeout = 90
        .ConnectionString = m_strConnText
        .Mode = adModeRead

    End With
    


If m_objConnText.State = adStateClosed Then
    Application.StatusBar = "Connecting to the local Excel tables"
    m_objConnText.Open
End If



Set connText = m_objConnText

ExitSub:
    Application.StatusBar = False
    Exit Property
    
ErrSub:
    MsgBox "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10
    Resume ErrEnd
    ' Resume ExitSub
ErrEnd:
    End   ' Terminal error. Halt.
End Property


Public Sub CloseConnections()

On Error Resume Next

Set m_objConnText = Nothing

End Sub


Public Function FetchRecordset(SQL As String) As ADODB.Recordset
' Fetch records from the saved text files extracted by reading all those Excel ranges
' It is assumed that you know the arcane SQL conventions for the Microsoft TEXT driver

Dim rst As ADODB.Recordset

On Error Resume Next

Dim i As Integer
Dim iFrom As Integer



Set FetchRecordset = New ADODB.Recordset

With FetchRecordset

    .CacheSize = 8
    Set .ActiveConnection = connText

    On Error GoTo ERR_ADO
    .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch

    i = 0
    Do While .State > 1
        i = (i + 1) Mod 3
        Application.StatusBar = "Connecting to the database" & String(i, ".")
        Application.Wait Now + (0.25 / 24 / 3600)
    Loop
    
End With

Application.StatusBar = False


ExitSub:
    Exit Function
    
    
ERR_ADO:

Dim strMsg
    strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the Desktop Support team."
    MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext
    Resume ExitSub
    

End Function


Public Function FetchXLRecordSet(SQL As String, ParamArray TableNames()) As ADODB.Recordset
' This allows you to retrieve data from Excel ranges using SQL

' ...Using Range names directly, by copying the range data to .csv files in a temp
' folder...

' As the Excel OLEDB and ODBC database drivers have problems with multiple running
' instances of Excel, this function has been implemented to use a text driver. You
' need to pass additional parameters specifying each range you're using as a table
' so that the these ranges can be saved as csv files in the SQLXL temporary folder

' Note that your query must still use the naming conventions required by the Excel
' database drivers: http://www.connectionstrings.com/excel#20


' Sample usage:
'
'   Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap")
'
' Where the query uses two named ranges, "TableAccountLookup" and "TableCashMap"
' as shown in this SQL statement:
'
'    SELECT
'        B.Legal_Entity_Name, B.Status,
'        SUM(A.USD_Settled) As Settled_Cash
'    FROM
'        [TableAccountLookup] AS A,
'        [TableCashMap] AS B
'    WHERE
'        A.Account  IS NOT NULL
'    AND B.Cash_Account  IS NOT NULL
'    AND A.Account = B.Cash_Account
'    Group BY
'        B.Legal_Entity_Name,
'        B.Status


On Error Resume Next

Dim i As Integer
Dim iFrom As Integer
Dim strRange As String




Set FetchXLRecordSet = New ADODB.Recordset

With FetchXLRecordSet
    
    .CacheSize = 8
    Set .ActiveConnection = connText    ' This recreates the database connection, and clears
                                            ' the temporary folder containing our csv data files
    
    iFrom = InStr(8, SQL, "From", vbTextCompare) + 4
    For i = LBound(TableNames) To UBound(TableNames)
        strRange = ""
        strRange = TableNames(i)
        RangeToFile strRange
        SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1)
    Next i
    SQL = Replace(SQL, ".csv.csv", ".csv")
    
    .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch

    i = 0
    Do While .State > 1
        i = (i + 1) Mod 3
        Application.StatusBar = "Connecting to the database" & String(i, ".")
        Application.Wait Now + (0.25 / 24 / 3600)
    Loop
    
End With

Application.StatusBar = False

End Function



Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String
' Read a range into a string.
' Each row is delimited with a carriage-return and a line break.
' Empty cells are concatenated into the string as 'Tabs' of four spaces.
Application.Volatile False

Dim i As Integer
Dim j As Integer
Dim arrRows As Variant
Dim strRow As String


arrRows = SQL_Range.Value2

If InStr(TypeName(arrRows), "(") Then

    For i = LBound(arrRows, 1) To UBound(arrRows, 1)
    
        strRow = ""
        
        For j = LBound(arrRows, 2) To UBound(arrRows, 2)
            
            If Trim(arrRows(i, j)) = "" Then
                arrRows(i, j) = "    "
            End If
            strRow = strRow & arrRows(i, j)
    
        Next j
        
        strRow = RTrim(strRow)
        If strRow <> "" Then
            ReadRangeSQL = ReadRangeSQL & strRow & vbCrLf
        End If
        
    Next i

    Erase arrRows
Else
    ReadRangeSQL = CStr(arrRows)
End If



End Function


Public Sub RangeToFile(ByRef strRange As String)
' Output a range to a csv file in a temporary folder created by the connText function
' strRange specifies a range in the current workbook using the 'table' naming conventions
' specified for Excel OLEDB database drivers:   http://www.connectionstrings.com/excel#20

' Note that the first row of the range is assumed to be a set of column names.

On Error Resume Next


If objFSO Is Nothing Then
    Exit Sub
End If


Dim rng     As Excel.Range
Dim strFile As String
Dim arrData As Variant
Dim iRow    As Long
Dim jCol    As Long
Dim strData As String
Dim strLine As String

strRange = Replace(strRange, "[", "")
strRange = Replace(strRange, "]", "")

If Right(strRange, 1) = "$" Then
    strRange = Replace(strRange, "$", "")
    Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
Else
    strRange = Replace(strRange, "$", "")
    Set rng = Range(strRange)
End If

If rng Is Nothing Then
    Exit Sub
End If



If objFSO Is Nothing Then
    Exit Sub
End If



strFile = m_strTempFolder & strRange & ".csv"

If objFSO.FileExists(strFile) Then
    objFSO.DeleteFile strFile, True
End If

If objFSO.FileExists(strFile) Then
    Exit Sub
End If

arrData = rng.Value2

With objFSO.OpenTextFile(strFile, 2, True)  ' ForReading = 1, ForWriting = 2, ForAppending = 8

    ' Header row:
    strLine = ""
    strData = ""
    iRow = LBound(arrData, 1)
    For jCol = LBound(arrData, 2) To UBound(arrData, 2)
        strData = arrData(iRow, jCol)
        strData = Replace(strData, Chr(34), Chr(39))
        strData = Replace(strData, Chr(10), " ")
        strData = Replace(strData, Chr(13), " ")
        strData = strData & ","
        strLine = strLine & strData
    Next jCol
    
    strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma
        
    If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
        .writeline strLine
    End If
        
    ' Rest of the data
    For iRow = LBound(arrData, 1) + 1 To UBound(arrData, 1)
    
        strLine = ""
        strData = ""
        
        For jCol = LBound(arrData, 2) To UBound(arrData, 2)
            If IsError(arrData(iRow, jCol)) Then
                strData = "#ERROR"
            Else
                strData = arrData(iRow, jCol)
                strData = Replace(strData, Chr(34), Chr(39))
                strData = Replace(strData, Chr(10), " ")        ' removing line breaks is not RFC 4180 compliant
                strData = Replace(strData, Chr(13), " ")        ' ...but the Excel driver will break if we don't
                strData = Replace(strData, Chr(9), " ")
                strData = Trim(strData)
            End If
            strData = Chr(34) & strData & Chr(34) & ","         ' Enclosing by quotes coerces all values to text
            strLine = strLine & strData
        Next jCol
        
        strLine = Left(strLine, Len(strLine) - 1)    ' Trim trailing comma
        
        If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
            .writeline strLine
        End If
        
    Next iRow
    
.Close
End With ' textstream object from objFSO.OpenTextFile

Erase arrData
Set rng = Nothing

End Sub




Public Sub ArrayToFile(ByRef arrData As Variant, ByVal strName As String, Optional bTranspose As Boolean = False, Optional Header As String = "", Optional CoerceText As Boolean = True)

' Output an array to a csv file in a temporary folder created by the connText function
' arrRange is data from a range

' Note that the first row of the array is assumed to be a set of column names.

On Error Resume Next




Dim iRow    As Long
Dim jCol    As Long
Dim strData As String
Dim strLine As String
Dim strFile As String
Dim iOffset As Long

Dim arrHeaders  As Variant
Dim i           As Long

If objFSO Is Nothing Then
    Exit Sub
End If

If Right(strName, 1) = "$" Then
    strName = Left(strName, Len(strName) - 1)
End If



strFile = TempSQLFolder & strName & ".csv"

If objFSO.FileExists(strFile) Then
    objFSO.DeleteFile strFile, True
End If

If objFSO.FileExists(strFile) Then
    Exit Sub
End If



With objFSO.OpenTextFile(strFile, 2, True)  ' ForReading = 1, ForWriting = 2, ForAppending = 8

    ' Header row:
    strLine = ""
    strData = ""
    
    If Header <> "" Then
         .writeline Header
         iOffset = 0
         
         If CoerceText Then
            arrHeaders = Split(Header, ",")
            For i = LBound(arrHeaders) To UBound(arrHeaders)
                arrHeaders(i) = Chr(34) & "Type=Text" & Chr(34)
            Next i
            For i = 1 To 25
            .writeline Join(arrHeaders, ",")
            Next i
            Erase arrHeaders
         End If
         
    Else
        iOffset = 1
    End If
    
    
    
    If Not IsEmpty(arrData) Then
    If bTranspose Then
    
        If Header = "" Then
        
            iRow = LBound(arrData, 1)
            For jCol = LBound(arrData, 1) To UBound(arrData, 1)
            
                If IsNull(arrData(jCol, iRow)) Then
                    strData = ""
                ElseIf IsEmpty(arrData(jCol, iRow)) Then
                    strData = ""
                Else
                    strData = arrData(jCol, iRow)
                    strData = Replace(strData, Chr(34), Chr(39))
                    strData = Replace(strData, Chr(10), " ")
                    strData = Replace(strData, Chr(13), " ")
                    If IsDate(strData) Then
                         strData = CDbl(CVDate(strData))
                    End If
                End If
                strData = strData & ","
                strLine = strLine & strData
                
            Next jCol
            
            strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma
                
            If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
                .writeline strLine
            End If
            
        End If
        
        
        ' Rest of the data
        For iRow = LBound(arrData, 2) + iOffset To UBound(arrData, 2)
        
            strLine = ""
            strData = ""
            
            For jCol = LBound(arrData, 1) To UBound(arrData, 1)
                If IsError(arrData(jCol, iRow)) Then
                    strData = "#ERROR"
                ElseIf IsNull(arrData(jCol, iRow)) Then
                    strData = ""
                ElseIf IsEmpty(arrData(jCol, iRow)) Then
                    strData = ""
                Else
                    strData = arrData(jCol, iRow)
                    strData = Replace(strData, Chr(34), Chr(39))
                    strData = Replace(strData, Chr(10), " ")        ' removing line breaks is not RFC 4180 compliant
                    strData = Replace(strData, Chr(13), " ")        ' ...but the Excel driver will break if we don't
                    strData = Replace(strData, Chr(9), " ")
                    If IsDate(strData) Then
                         strData = CDbl(CVDate(strData))
                    End If
                End If
                    
                strData = Trim(strData)
                    
                strData = Chr(34) & strData & Chr(34) & ","         ' Enclosing by quotes coerces all values to text
                strLine = strLine & strData
            Next jCol
            
            strLine = Left(strLine, Len(strLine) - 1)    ' Trim trailing comma
            
            If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
                .writeline strLine
            End If
            
        Next iRow
        
    
    
    Else
    
    
        If Header = "" Then
        
            iRow = LBound(arrData, 1)
            For jCol = LBound(arrData, 2) To UBound(arrData, 2)
            
                If IsNull(arrData(iRow, jCol)) Then
                    strData = ""
                ElseIf IsEmpty(arrData(iRow, jCol)) Then
                    strData = ""
                Else
                    strData = arrData(iRow, jCol)
                    strData = Replace(strData, Chr(34), Chr(39))
                    strData = Replace(strData, Chr(10), " ")
                    strData = Replace(strData, Chr(13), " ")
                    If IsDate(strData) Then
                         strData = CDbl(CVDate(strData))
                    End If
                End If
                
                strData = strData & ","
                strLine = strLine & strData
                
            Next jCol
            
            strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma
                
            If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
                .writeline strLine
            End If
            
        End If
        
        
            
        ' Rest of the data
        For iRow = LBound(arrData, 1) + iOffset To UBound(arrData, 1)
        
            strLine = ""
            strData = ""
            
            For jCol = LBound(arrData, 2) To UBound(arrData, 2)
                If IsError(arrData(iRow, jCol)) Then
                    strData = "#ERROR"
                ElseIf IsNull(arrData(iRow, jCol)) Then
                    strData = ""
                ElseIf IsEmpty(arrData(iRow, jCol)) Then
                    strData = ""
                Else
                    strData = arrData(iRow, jCol)
                    strData = Replace(strData, Chr(34), Chr(39))
                    strData = Replace(strData, Chr(10), " ")        ' removing line breaks is not RFC 4180 compliant
                    strData = Replace(strData, Chr(13), " ")        ' ...but the Excel driver will break if we don't
                    strData = Replace(strData, Chr(9), " ")
                    strData = Trim(strData)
                    If IsDate(strData) Then
                         strData = CDbl(CVDate(strData))
                    End If
                End If
                strData = Chr(34) & strData & Chr(34) & ","         ' Enclosing by quotes coerces all values to text
                strLine = strLine & strData
            Next jCol
            
            strLine = Left(strLine, Len(strLine) - 1)    ' Trim trailing comma
            
            If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
                .writeline strLine
            End If
            
        Next iRow
        
    End If ' bTranspose
    End If '  If Not IsEmpty(arrData) Then
 
.Close
End With ' textstream object from objFSO.OpenTextFile

  

End Sub


Public Function GetDataFromClosedWorkbook(ByVal SourceFile As String, _
                                          ByVal SourceRange As String, _
                                 Optional ByRef FieldNames As String = "", _
                                 Optional ByVal ReadHeaders As Boolean = False, _
                                 Optional ByVal LocalCopyLifetime As Double = 1#, _
                                 Optional ByVal ForceRecopy As Boolean = False, _
                                 Optional ByVal Asynchronous As Boolean = False) As Variant

Application.Volatile False
On Error GoTo ErrSub
' Read a Range in a closed workbook (which remains closed throughout the operation - we do not open the file in Excel)
' Returns a TRANSPOSED variant array, in which the first column will be the headers

' If your range is a worksheet, append "$" to the worksheet name

' If you set ReadHeaders=True, the first row of your data will be treated as the field names of a table; this means that you can pass
' a SQL query instead of a range or table name BUT the fierst row of your range will not be included in the returned variant array

' Note that we do not attempt to examine files on network folders: we always copy to a temporary folder

'      - However, we'll only overwrite a pre-existing local copy if the pre-existing file is older than LocalCopyLifetime days
'      - While the copy-to-local-folder operation in running in asynchronous mode, the function will return #WAITING FOR FILE TRANSFER

' Be warned, the ACE database drivers have serious stability issues and Excel will definitely crash a couple of times


' TO DO: modify parsing of 'Source Sheet' so that we can read a defined name or a range address


Dim objConnect  As ADODB.Connection
Dim rst         As ADODB.Recordset
Dim strConnect  As String

Dim i           As Long
Dim j           As Long
Dim arrData     As Variant
Dim TempFile    As String
Dim strTest     As String
Dim SQL         As String
Dim iColCount   As Long
Dim strPathFull As String


Dim strHeaders As String

If SourceFile = "" Then
    Exit Function
End If


' Parse out web folder paths

If Left(SourceFile, 5) = "http:" Then

    SourceFile = Right(SourceFile, Len(SourceFile) - 5)
    SourceFile = Replace(SourceFile, "%20", " ")
    SourceFile = Replace(SourceFile, "%160", " ")
    SourceFile = Replace(SourceFile, "/", "\")

End If




strPathFull = SourceFile
    




If Len(Dir(SourceFile)) = 0 Then
    GetDataFromClosedWorkbook = "#ERROR Source file not found"
    
    Exit Function
End If


If objFSO Is Nothing Then
    Exit Function
End If


TempFile = objFSO.GetSpecialFolder(2).Path & "\" & Filename(SourceFile)
    
    
If ForceRecopy Then

    If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
        VBA.FileSystem.Kill TempFile
    End If
    
End If

If Not (Left(SourceFile, 3) = "C:\" Or Left(SourceFile, 3) = "D:\") Then


  ' Always copy to the local drive
  
    If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
    
        On Error Resume Next
        If VBA.FileSystem.FileDateTime(TempFile) < VBA.FileSystem.FileDateTime(SourceFile) Then
            VBA.FileSystem.Kill TempFile
        ElseIf m_objFSO.GetFile(TempFile).dateLastAccessed < (Now - LocalCopyLifetime) Then
            VBA.FileSystem.Kill TempFile
        End If
        
    End If
    
    If Len(VBA.FileSystem.Dir(TempFile)) = 0 Then
    
        If Asynchronous Then
            Shell "cmd /c COPY " & Chr(34) & SourceFile & Chr(34) & " " & Chr(34) & TempFile & Chr(34), vbHide
            GetDataFromClosedWorkbook = "#WAITING FOR FILE TRANSFER"
            Exit Function
        Else
     
            VBA.FileSystem.FileCopy SourceFile, TempFile
           
            
        End If
        
    Else
        SourceFile = TempFile
    End If

End If


If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
    strHeaders = "HDR=Yes"
ElseIf ReadHeaders = True Then
    strHeaders = "HDR=Yes"
Else
    strHeaders = "HDR=No"
End If

' " & strHeaders & "


    If Right(SourceFile, 4) = ".xls" Then    '
    
       ' strConnect = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
        
        strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
      
        'strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
      
    ElseIf Right(SourceFile, 5) = ".xlsx" Then
    
        strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Xml;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
    
    ElseIf Right(SourceFile, 5) = ".xlsm" Then
        
        'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
 
        strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Macro;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
    
    ElseIf Right(SourceFile, 5) = ".xlsb" Then
      
        'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
        ' This ACE driver is unstable on xlsb files... But it's more likely to return a result, if you don't mind crashes:
        strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
    
    Else
        GetDataFromClosedWorkbook = "#ERROR - file format not known"
    End If
    
    On Error GoTo ErrSub
    
    'SetTypeGuessRows
    
    Set objConnect = New ADODB.Connection
    With objConnect
    
        .ConnectionTimeout = 60
        .CommandTimeout = 90
        .Mode = adModeRead
        .ConnectionString = strConnect

        .Open

    End With

    
    Set rst = New ADODB.Recordset
    
    With rst
        
        .CacheSize = 8
        .PageSize = 8
         
        If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
            SQL = SourceRange
        Else
            .MaxRecords = 8192
           SQL = "SELECT * FROM [" & SourceRange & "] "
        End If
        
        .Open SQL, objConnect, adOpenStatic, adLockReadOnly
    
    End With
     
    On Error Resume Next
    
    For i = 0 To rst.Fields.Count - 1
        FieldNames = FieldNames & rst.Fields(i).Name & ","
    Next i
    FieldNames = Left(FieldNames, Len(FieldNames) - 1)
    
    If rst.EOF And rst.BOF Then
        'no action
    Else
        Err.Clear
        rst.MoveFirst
        GetDataFromClosedWorkbook = rst.GetRows
        
        If IsEmpty(GetDataFromClosedWorkbook) Then
            rst.MoveFirst
            GetDataFromClosedWorkbook = rst.GetRows
        End If
        
        If IsEmpty(GetDataFromClosedWorkbook) Then
            
            rst.MoveFirst
            ReDim arrTemp(0 To rst.Fields.Count - 1, 0 To rst.RecordCount)
            i = 0
            j = 0
            Do Until rst.EOF
            
                Err.Clear
                If i > UBound(arrTemp, 2) Then
                    ReDim Preserve arrTemp(0 To rst.Fields.Count - 1, 0 To i)
                End If
                
                For j = 0 To rst.Fields.Count - 1
                    arrTemp(j, i) = rst.Fields(j).Value
                    If Err.Number = &HBCD Then
                        Exit For
                    End If
                Next j
                
                i = i + 1
            
           
                If Err.Number <> &HBCD Then
                    rst.MoveNext
                End If
                
                If Err.Number <> &H80004005 And Err.Number <> 0 Then
                    Exit Do
                End If
                
            Loop
            
            GetDataFromClosedWorkbook = arrTemp
            Erase arrTemp
            
        End If ' IsEmpty(GetDataFromClosedWorkbook)
        
        
    End If '  rst.EOF And rst.BOF Then
    
ExitSub:
On Error Resume Next

    rst.Close
    objConnect.Close ' close the database connection
    
    Set rst = Nothing
    Set objConnect = Nothing

    

    Exit Function
    
ErrSub:

    If InStr(Err.Description, "not a valid name") Then
        GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist"
        MsgBox "Cannot read the data from file: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "It's possible that the file has been locked, but the most likely explanation is that the file doesn't contain the named sheet or range you're trying to read: check that you've saved the correct C7 report with the correct file name." & vbCrLf & vbCrLf & "If this error persists, please contact the Desktop Support team.", vbCritical, APP_NAME & ": data access error:"
    ElseIf InStr(Err.Description, "Could not find the object '& SourceRange") Then
        GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist"
        MsgBox Err.Description & vbCrLf & vbCrLf & "Please contact the Desktop Support  team. This error probably means that source file is locked, or that the wrong file has been saved here: " & vbCrLf & vbCrLf & strPathFull, vbCritical, APP_NAME & ": file data error:"
    ElseIf InStr(Err.Description, "Permission Denied") Then
        GetDataFromClosedWorkbook = "#ERROR Access to file"
        MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf & vbCrLf & "Another user probably has this file open. Please wait a few minutes, and try again. If this error persists, please contact Desktop Support team.", vbCritical, APP_NAME & ": file access error:"
    Else
        GetDataFromClosedWorkbook = "#ERROR " & Err.Number & ": " & Err.Description
    End If
   
    Resume ExitSub
    
    
' # leave in place for debugging:
    Resume
    
End Function



Public Function Filename(ByVal strPath As String) As String


strPath = Replace(strPath, "/", "\")

If strPath <> "" Then

    Filename = StrReverse(Split(StrReverse(strPath), "\")(0))

End If

End Function

Public Function Folder(ByVal strPath As String) As String


strPath = Replace(strPath, "/", "\")

If strPath <> "" Then
 
     Folder = Left(strPath, Len(strPath) - Len(Filename(strPath)))

End If

End Function


Public Sub SetTypeGuessRows()
On Error Resume Next ' necessary because there is no other way of checking the existence of a key

'http://msdn.microsoft.com/en-us/library/yfdfhz1b(v=vs.84).aspx

Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")

Dim strKey As String


strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If











strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If
    
    
    
    
 



strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If
    
    
       
    

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If











strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If













strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"

    If objShell.RegRead(strKey) <> "Text" Then
        objShell.RegWrite strKey, "Text", "REG_SZ"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"
        objShell.RegWrite strKey, "Text", "REG_SZ"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If

strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"

    If objShell.RegRead(strKey) <> 0 Then
        objShell.RegWrite strKey, 0, "REG_DWORD"
    End If
    
    If objShell.RegRead(strKey) <> 0 Then
    
        strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
        strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"
        objShell.RegWrite strKey, 0, "REG_DWORD"
        
    End If


Set objShell = Nothing

End Sub

You will also need basArrays, a grab bag of array-handling utilities. I've posted the full set elsewhere, but these are the array functions in use in the code above:

Option Explicit
Option Private Module

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                   (Destination As Any, _
                    Source As Any, _
                    ByVal Length As Long)
                    
                    
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.

On Error Resume Next

'
' Author: Nigel Heffernan  Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True


If IsEmpty(InputArray) Then
    Exit Sub
End If

If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If


' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)


If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)


ElseIf iDimensions = 1 Then

    
    iRowCount = UBound(InputArray) - LBound(InputArray)
    iStart = LBound(InputArray)
    iColCount = 1
    
    If iRowCount > (655354 - rngTarget.Row) Then
        iRowCount = 655354 + iStart - rngTarget.Row
        ReDim Preserve InputArray(iStart To iRowCount)
    End If
    
    iRowCount = UBound(InputArray) - LBound(InputArray)
    iColCount = 1
    
    ' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
    ' By convention, a vector is presented in Excel as an array of 1 to n rows and 1 column.
    ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next
    
    With rngTarget.Worksheet
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
        rngOutput.Value2 = arrTemp
        Set rngTarget = rngOutput
    End With
    
    Erase arrTemp
    
    

ElseIf iDimensions = 2 Then
    
    
    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
    
    iStart = LBound(InputArray, 1)
    
    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If
    
    
    iStart = LBound(InputArray, 2)
    If iColCount > (254 - rngTarget.Column) Then
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If
    
    
    
    With rngTarget.Worksheet
    
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
    
        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True
    
        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
    
                    If IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You *have*
                            ' to go back and check, and write this masterpiece one cell at a time...
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True
    
    
        End If 'err<>0
    
    
        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time
    
    End With  '  rngTarget.Worksheet
    


End If  ' iDimensions



End Sub

Public Function ArrayTranspose(InputArray As Variant) As Variant

Dim arrOutput As Variant

Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long

iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)

ReDim arrOutput(jMin To jMax, iMin To iMax)

For i = iMin To iMax
    For j = jMin To jMax
        arrOutput(j, i) = InputArray(i, j)
    Next j
Next i

ArrayTranspose = arrOutput

End Function


Private Function ArrayDimensions(arr As Variant) As Integer
  '-----------------------------------------------------------------
  ' will return:
  ' -1 if not an array
  ' 0  if an un-dimmed array
  ' 1  or more indicating the number of dimensions of a dimmed array
  '-----------------------------------------------------------------


  ' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' Code written by Chris Rae, 25/5/00

  ' Originally published by R. B. Smissaert.
  ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax

  Dim ptr As Long
  Dim vType As Integer

  Const VT_BYREF = &H4000&

  'get the real VarType of the argument
  'this is similar to VarType(), but returns also the VT_BYREF bit
  CopyMemory vType, arr, 2

  'exit if not an array
  If (vType And vbArray) = 0 Then
    ArrayDimensions = -1
    Exit Function
  End If

  'get the address of the SAFEARRAY descriptor
  'this is stored in the second half of the
  'Variant parameter that has received the array
  CopyMemory ptr, ByVal VarPtr(arr) + 8, 4

  'see whether the routine was passed a Variant
  'that contains an array, rather than directly an array
  'in the former case ptr already points to the SA structure.
  'Thanks to Monte Hansen for this fix

  If (vType And VT_BYREF) Then
    ' ptr is a pointer to a pointer
    CopyMemory ptr, ByVal ptr, 4
  End If

  'get the address of the SAFEARRAY structure
  'this is stored in the descriptor

  'get the first word of the SAFEARRAY structure
  'which holds the number of dimensions
  '...but first check that saAddr is non-zero, otherwise
  'this routine bombs when the array is uninitialized

  If ptr Then
    CopyMemory ArrayDimensions, ByVal ptr, 2
  End If

End Function


Public Function TableLookup(TableRange As Excel.Range, Optional ColumnLabel As String = "", Optional RowLabel As Variant = "", Optional IndexColumn As Long = 1, Optional Compare As VbCompareMethod = vbTextCompare) As Excel.Range
Application.Volatile False
On Error GoTo ErrSub

' For a contiguous data range having column labels in Row 1, return:
'   The data range, excluding the header row, if no column and row labels are specified;
'   The named data column, excluding the header, if a column label is supplied;
'   The labelled data row, if a row label is supplied;
'   The first data cell matching the column and row label, if both are supplied.
'   The 'index' column containing data row labels is assumed to be 1 (the leftmost column) unless specified by IndexColumn


' If you're calling this repeatedly, consider coding up an indexed
' array with Scripting.Dictionary objects as row & column indices.


Dim rngData As Excel.Range
Dim rngCol  As Excel.Range
Dim rngRow  As Excel.Range
Dim rngCell As Excel.Range

Dim iRow As Long
Dim iCol As Long
Dim iRowCount   As Long
Dim iColCount   As Long


Dim arrColLabel As Variant
Dim arrRowLabel As Variant


iRowCount = TableRange.Rows.Count
iColCount = TableRange.Columns.Count

If iRowCount = 0 Then
    Exit Function
End If


' Check for invalid Index column
If IndexColumn > TableRange.Worksheet.Columns.Count - TableRange.Column Then 'column is off the Right-Hand edge of the sheet
    
    Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the right-hand edge of the worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."

ElseIf IndexColumn + TableRange.Column < 1 Then                              'column is off the Left-Hand edge of the sheet
    
    Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the left-hand edge worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."

End If





Set rngData = TableRange.Worksheet.Range(TableRange.Cells(2, 1), TableRange.Cells(iRowCount, iColCount))


' Orthogonal branches: however we do this, there will be some duplicated code
' This is coded up for readability: feel free to refactor for performance and
' remove any code you consider redundant - but *you* maintain it afterwards

If ColumnLabel = "" And RowLabel = "" Then

    Set TableLookup = rngData
    
ElseIf ColumnLabel <> "" And RowLabel = "" Then  ' return a column of data

    arrColLabel = TableRange.Rows(1).Value2
    For iCol = 1 To iColCount
    
        If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
            Exit For
        End If
        
    Next iCol
    Erase arrColLabel
    
    If iCol > iColCount Then
        Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
    Else
        Set TableLookup = rngData.Columns(iCol)
    End If
    
ElseIf ColumnLabel = "" And RowLabel <> "" Then  ' return a row of data
    
    arrRowLabel = rngData.Cols(IndexColumn).Value2
    For iRow = 1 To iRowCount - 1
    
        If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
            'Numeric Comparison
            If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        
        ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
            ' Date comparison
            If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        Else
            ' string comparison
            If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
                Exit For
            End If
        End If
        
    Next iRow
    Erase arrColLabel
    
    If iRow >= iRowCount Then
        Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
    Else
        Set TableLookup = rngData.Rows(iRow)
    End If
    
    
ElseIf ColumnLabel <> "" And RowLabel <> "" Then  ' return a cell of data

    arrColLabel = TableRange.Rows(1).Value2
    For iCol = 1 To iColCount
    
        If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
            Exit For
        End If
        
    Next iCol
    Erase arrColLabel
    
    If iCol > iColCount Then
        Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
    End If
    
        arrRowLabel = rngData.Cols(IndexColumn).Value2
    For iRow = 1 To iRowCount - 1
    
        If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
            'Numeric Comparison
            If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        
        ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
            ' Date comparison
            If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        Else
            ' string comparison
            If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
                Exit For
            End If
        End If
        
    Next iRow
    Erase arrColLabel
    
    If iRow >= iRowCount Then
        Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
    Else
        Set TableLookup = rngData.Cells(iRow, iCol)
    End If
    
        
End If


ExitSub:
    Exit Function
    
ErrSub:
    
    If Err.HelpContext = 0 Then
        MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source
    Else
        MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source, Err.HelpFile, Err.HelpContext
    End If
    
    Resume ExitSub
    
    Resume
End Function