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