Friday 3 July 2015

A Fishy Tale of Report Support


Not, strictly speaking, an Excel post at all: but I thought I'd share this with you anyway.

From time to time, I have to cover the support work on a large reporting system which serves Excel files out through a web portal. We're running something between five hundred and a thousand distinct reports.

Here's an edited - heavily redacted! - transcript of a typical support call, with the details changed to protect commercial confidentiality, and the fundamental concepts entirely unaltered:

  Fish:    "Hi, Aquarium Support Desk?"   Support: "Hello, this is the Aquarium Support Desk, can I help you?"   Fish:    "It's the water"   Support: "There's something wrong with your water?"   Fish:    "Yes, there's something wrong with the water: can you help?"
  Support: * Thinks * I could ask what's wrong with the water, again...   Support: ...But it's going to be quicker to get the testing kit and go there myself
  Support: "Which tank are you in?"   Fish:    "Yes, I have a problem with the water"   Support: "I need to run some tests, can you tell me which tank has a problem with the water"   Fish:    "Thanks, how long will it take you to fix this?"   Support: "I don't know which one of the 450 tanks of water in this building has a problem, and I need to know which tank to test"   Fish:    "It's a problem with the water, can you tell me how long it'll be?"   Support: "Are there any identifying marks on your tank?"

There's no 'punchline'... So lets stop right there, and nail the mistake before the repetition gets tedious.

The Fish has no concept for 'Tank' and the support technician doesn't realise that nothing AT ALL is communicated in any question or statement centred on 'tank' and 'location'.

Maybe if Support used the word 'Aquarium', they'd get a response; and maybe not - some people have a distinct vocabulary for their work, and the concepts embedded in their work can only be communicated in that exact language (Oracle administrators are the most extreme example) - but it's entirely possible that the fish has NO vocabulary for, and no concept of, a distinct body of water with a boundary container.

That's not to say the fish is stupid - I'd like to see how long *you* would last on a tropical reef, and your attempts at breathing when immersed in water are, quite frankly, embarrassing - and anyway, the problem was never going to be solved by being 'smarter' than the fish.

The problem is going to be solved by being smarter than a support technician who doesn't see that that a gap in communication isn't going to be fixed by throwing more questions down the the same hole: asking for more details about the tank won't work, no matter how many questions you ask, if 'Tank' is a concept you can't communicate at all.

So here's the 'fix': ask a question centred on a concept the user will understand, with answers that will 'leak' location information:

  Support: * Mutters, almost as if he or she doesn't want to be heard *   Support: "It's the 4%@#ing octopus again"   Support: * Asks, clearly and politely: *   Support: "Is there an octopus in the tank adjacent to yours?"   Fish:    "There's a Pacific blue-ringed female so sunward..."   Fish:    "And a tuberculate pelagic octopus next to the source of vibration I complained about last week"
  Support: "Tank 224. I'll be right over with the testing kit"

Something else for you to ponder: the 'user experience' here is that Support asked no end of irrelevant questions that elucidated nothing except their own cluelessness, and they took their own sweet time to get to work on the problem.

And the first thing the user will see is support faffing around with a testing kit, when they've already been told, repeatedly, that there's something wrong with the water.

Support isn't a technical skill, it's about communication and manipulation. And if you are wondering how this fishy tale is relevant: more than half the time expended by support technicians in speaking to the users consists of failed attempts to identify the specific report that the user needed fixing..

So anyone who builds reports - or Excel applications - and releases them for widespread use needs to be labelling-up *every* sheet with the app or report name, and filling in a 'Settings' or 'about this report' or 'documentation' sheet that the user can be guided to by first-line support. Or by you.

And the moral is:

The most important piece of information that your application, worksheet, or report can communicate to a support technician is an unambiguous identifying name; and, better still, a location.


Meanwhile, I will buy you beer if you can bring a toxic blue-ringed octopus into today's technical explanations to the users.


Sunday 25 January 2015

Trusted Locations: a source of misleading error messages


When's the last time you ran some VBA that opened a spreadsheet over the network? Or even on your own local temp folder?

If you're working in Office 2010 or 2013, you might just have seen this error message:

Office has detected a problem with this file. To help protect your computer this file cannot be opened.



...But you open the file yourself, manually, and it's fine. Readable, no error messages on open, maybe contains VBA macros and COM controls and you get a warning message, but not corrupted or obviously malicious.

You *might* see a message about content disabled, or the 'Trust Centre'.

What's actually happened is that the 'Trust Centre' ('Trust Center' in American English) needs a manual intervention to add the folder containing your file, and to label it as a safe location.

Microsoft have published instructions on doing this here:

Support.Office.com: Add, remove, or change a trusted location

That's great if it's just you, but unhelpful if you write applications that open Excel files. But, before I show you the VBA to automate away that annoyance, here's a short code snippet for opening Excel files safely in a separate 'sanitised' instance of Excel.exe:

Application.ShowStartupDialog = False With New Excel.Application     On Error Resume Next     .ShowStartupDialog = False     .Visible = False     .EnableCancelKey = xlDisabled     .UserControl = False     .Interactive = False     .EnableEvents = False     'If .Calculation <> xlCalculationManual Then     '    .Calculation = xlCalculationManual     'End If     '.CalculateBeforeSave = False     .DisplayAlerts = False     .AutomationSecurity = msoAutomationSecurityForceDisable          On Error Resume Next     For i = 1 To .AddIns.Count         If .AddIns(i).IsOpen Then             .AddIns(i).Installed = False         End If     Next i          For i = 1 To .COMAddIns.Count         .COMAddIns(i).Connect = False         If Not .COMAddIns(i).Object Is Nothing Then             .COMAddIns(i).Object.Close             .COMAddIns(i).Object.Quit         End If     Next i                On Error GoTo ErrAppExit          .Workbooks.Open FileName = strFile, _                      UpdateLinks:=False,  _                      ReadOnly:=True,  _                      Password:=vbNullString,  _                      Notify:=False,  _                      AddToMRU:=False        ' **** Your code to work on the file goes here ****     ' **** Set all objects to Nothing before exiting ****        For i = .Workbooks.Count To 1 Step -1          .Workbooks(i).Close      Next i ErrAppExit:     On Error Resume Next     If Err.Number > 0 Then         StatusMessage = "#ERROR " & Err.Number & ": " & Err.Description & sError     End If          .Quit      End With  'New Excel.Application 

The Trust Centre is annoying, but you might want to take *some* precautions when opening files from a bad neighborhood. Especially if others will use your VBA code to open files from places you never heard of.

Whatever. Here's the code to set a trusted location which I posted in StackOverflow a couple of days ago:

TrustThisFolder(): Excel VBA Code to Add a Folder to the 'Trusted Folders' Registry List.




Private Sub TrustThisFolder(Optional FolderPath As String, _                             Optional TrustSubfolders As Boolean = True, _                             Optional TrustNetworkFolders As Boolean = False, _                             Optional sDescription As String) ' Add a folder to the 'Trusted Locations' list so that your project's VBA can ' open Excel files without raising errors like "Office has detected a problem ' with this file. To help protect your computer this file cannot be opened." ' Ths function has been implemented to fail silently on error: if you suspect ' that users don't have permission to assign 'Trusted Location' status in all ' locations, reformulate this as a function returning True or False ' Nigel Heffernan January 2015 http:\\Excellerando.blogspot.com ' ' Based on code published by Daniel Pineault in DevHut.net on June 23, 2010: ' www.devhut.net\2010\06\23\vbscript-createset-trusted-location-using-vbscript\ ' **** **** **** ****  THIS CODE IS IN THE PUBLIC DOMAIN  **** **** **** **** ' UNIT TESTING: ' ' 1:    Reinstate the commented-out line 'Debug.Print sSubKey & vbTab & sPath ' 2:    Open the Immediate Window and run this command: '           TrustThisFolder "Z:\", True, True, "The user's home directory" ' 3:    If  "Z:\"  is already in the list, choose another folder ' 4:    Repeat step 2 or 3: the folder should be listed in the debug output ' 5:    If it isn't listed, disable the error-handler and record any errors ' On Error GoTo ErrSub Dim sKeyPath    As String Dim oRegistry   As Object Dim sSubKey     As String Dim oSubKeys    ' type not specified. After it's populated, it can be iterated Dim oSubKey     ' type not specified. Dim bSubFolders         As Boolean Dim bNetworkLocation    As Boolean Dim iTrustNetwork       As Long Dim sPath   As String Dim sDate   As String Dim sDesc   As String Dim i       As Long Const HKEY_CURRENT_USER = &H80000001 bSubFolders = True bNetworkLocation = False If FolderPath = "" Then     FolderPath = FSO.GetSpecialFolder(2).Path     If sDescription = "" Then         sDescription = "The user's local temp folder"     End If End If If Right(FolderPath, 1) <> "\" Then     FolderPath = FolderPath & "\" End If sKeyPath = "" sKeyPath = sKeyPath & "SOFTWARE\Microsoft\Office\" sKeyPath = sKeyPath & Application.Version sKeyPath = sKeyPath & "\Excel\Security\Trusted Locations\"       Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv") '   Note: not the usual \root\cimv2  for WMI scripting: the StdRegProv isn't in that folder   oRegistry.EnumKey HKEY_CURRENT_USER, sKeyPath, oSubKeys For Each oSubKey In oSubKeys     sSubKey = CStr(oSubKey)     oRegistry.GetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Path", sPath          'Debug.Print sSubKey & vbTab & sPath              If sPath = FolderPath Then         Exit For     End If           Next oSubKey If sPath <> FolderPath Then     If IsNumeric(Replace(sSubKey, "Location", "")) Then         i = CLng(Replace(sSubKey, "Location", "")) + 1     Else         i = UBound(oSubKeys) + 1     End If          sSubKey = "Location" & CStr(i)          If TrustNetworkFolders Then         iTrustNetwork = 1         oRegistry.GetDWORDValue HKEY_CURRENT_USER, sKeyPath, "AllowNetworkLocations", iTrustNetwork         If iTrustNetwork = 0 Then             oRegistry.SetDWORDValue HKEY_CURRENT_USER, sKeyPath, "AllowNetworkLocations", 1         End If     End If          oRegistry.CreateKey HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey     oRegistry.SetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Path", FolderPath     oRegistry.SetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Description", sDescription     oRegistry.SetDWORDValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "AllowSubFolders", 1      End If ExitSub:     Set oRegistry = Nothing     Exit Sub ErrSub:          Resume ExitSub End Sub

You will note that I acknowledge the original author, Daniel Pineault, who posted this code on DevHut.net in 2010: VB Script to set a Trusted Location

This code has been widely-reposted without attribution: please don't do that, it's discourteous - if you, too, aspire to being recognised as an 'expert', this can only happen if you're working in a culture that acknowledges expertise; and you, and your courtesy to others, *are* that culture.



Sunday 18 January 2015

Asterisk the Galling: Using The VBA InputBox() For Passwords

Using the VBA InputBox for passwords and hiding the user's keyboard input with asterisks.



This is another horrible hack, born from a requirement to stop storing Excel sheet and workbook passwords in the worksheets themselves, in the interests of security.

Experienced Excel developers, power users, IT security experts, and preserved rat brains floating in jars of formaldehyde might *just* be capable of reasoning-out one or two minor inconsistencies lurking in the logic of that statement.

However, I've still got to do it. And I can either create a VBA form and hope that the 'Password Chars' method exposed by some (but not all) textbox controls is reliable and secure, and can't be switched off by clever but misguided users; or just type the password into a standard VBA.Interaction InputBox() function.

Unfortunately, the InputBox function doesn't have a 'PasswordChars' option. So here's the simple and straightforward VBA code to do that, with the necessary API functions declared for both 64- and 32-bit environments:

Option Explicit #If VBA7 And Win64 Then    ' 64 bit Excel under 64-bit windows   ' Use LongLong and LongPtr     Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _                                     (ByVal hWnd1 As LongPtr, _                                      ByVal hWnd2 As LongPtr, _                                      ByVal lpsz1 As String, _                                      ByVal lpsz2 As String _                                      ) As LongPtr     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _                                     (ByVal lpClassName As String, _                                      ByVal lpWindowName As String) As LongPtr     Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _                                     (ByVal hwnd As LongPtr, _                                      ByVal wMsg As Long, _                                      ByVal wParam As Long, _                                      ByRef lParam As Any _                                      ) As LongPtr     Private Declare PtrSafe Function SetTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As LongPtr, _                                      ByVal uElapse As Long, _                                      ByVal lpTimerFunc As LongPtr _                                      ) As Long      Public Declare PtrSafe Function KillTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As LongPtr _                                      ) As Long      #ElseIf VBA7 Then     ' 64 bit Excel in all environments  ' Use LongPtr only, LongLong is not available     Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _                                     (ByVal hWnd1 As LongPtr, _                                      ByVal hWnd2 As LongPtr, _                                      ByVal lpsz1 As String, _                                      ByVal lpsz2 As String _                                      ) As LongPtr     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _                                     (ByVal lpClassName As String, _                                      ByVal lpWindowName As String) As LongPtr     Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _                                     (ByVal hwnd As LongPtr, _                                      ByVal wMsg As Long, _                                      ByVal wParam As Long, _                                      ByRef lParam As Any _                                      ) As LongPtr     Private Declare PtrSafe Function SetTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As Long, _                                      ByVal uElapse As Long, _                                      ByVal lpTimerFunc As LongPtr) As LongPtr     Private Declare PtrSafe Function KillTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As Long) As Long #Else    ' 32 bit Excel     Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _                             (ByVal hWnd1 As Long, _                              ByVal hWnd2 As Long, _                              ByVal lpsz1 As String, _                              ByVal lpsz2 As String _                              ) As Long     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _                             (ByVal lpClassName As String, _                              ByVal lpWindowName As String) As Long     Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _                             (ByVal hwnd As Long, _                              ByVal wMsg As Long, _                              ByVal wParam As Long, _                              ByRef lParam As Any _                              ) As Long     Private Declare Function SetTimer Lib "user32" _                             (ByVal hwnd As Long, _                              ByVal nIDEvent As Long, _                              ByVal uElapse As Long, _                              ByVal lpTimerFunc As Long) As Long     Public Declare Function KillTimer Lib "user32" _                             (ByVal hwnd As Long, _                              ByVal nIDEvent As Long) As Long #End If Private Const PASSBOX_INPUT_CAPTION As String = "Password Required" Private Const EM_SETPASSWORDCHAR    As Long = &HCC Private Const NV_INPUTBOX           As Long = &H5000& Public Function InputBoxPassword(Prompt As String, _                                  Optional Default As String = vbNullString, _                                  Optional XPos, Optional YPos, _                                  Optional HelpFile, Optional HelpContext _                                  ) As String On Error Resume Next ' Replicates the functionality of a VBA InputBox function, with the user's ' typed input displayed as asterisks. The 'Title' parameter for the dialog ' caption is hardcoded as "Password Required" in this implementation. ' REQUIRED function: TimerProcInputBox ' REQUIRED API declarations: FindWindow, FindWindowEx, SetTimer, KillTimer ' Nigel Heffernan, January 2015, HTTP://Excellerando.Blogspot.com ' **** **** **** *** THIS CODE IS IN THE PUBLIC DOMAIN **** **** **** **** ' Based on code posted by user 'manish1239' in Xtreme Visual Basic Talk in ' October 2003 http://www.xtremevbtalk.com/archive/index.php/t-112708.html ' Coding notes: we send the 'Set PasswordChar' message to the textbox edit ' window in the VBA 'InputBox' dialog.  This isn't a straightforward task: ' InputBox is synchronous, a 'Modal Dialog' which leaves our application's ' VBA code in a waiting state at the exact moment we need to call the Send ' Message API function. So it runs by a delayed callback from an API Timer ' Warning: many of the 64-bit API declarations posted online are incorrect ' and *none* of them are correct for the pointer-safe Timer API Functions. On Error Resume Next SetTimer 0&, 0&, 10&, AddressOf TimerProcInputBox InputBoxPassword = InputBox(Prompt, _                             PASSBOX_INPUT_CAPTION, _                             Default, _                             XPos, YPos, _                             HelpFile, HelpContext) End Function #If VBA7 And Win64 Then     ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr                             ' Note that wMsg is always the WM_TIMER message, which fits in a Long     Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As LongPtr, _                                  ByVal dwTime As LongLong)     On Error Resume Next                               ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          KillTimer hWndIbox, idEvent          Dim hWndIbox As LongPtr   ' Handle to VBA InputBox            hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")          If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If              End Sub      #ElseIf VBA7 Then          ' 64 bit Excel in all environments   ' Use LongPtr only     Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As LongPtr, _                                  ByVal dwTime As Long)     On Error Resume Next                               ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          Dim hWndIbox As LongPtr    ' Handle to VBA InputBox          KillTimer hwnd, idEvent          hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")                If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If                       End Sub      #Else    ' 32 bit Excel     Public Sub TimerProcInputBox(ByVal hwnd As Long, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As Long, _                                  ByVal dwTime As Long)     On Error Resume Next          ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          Dim hWndIbox As Long    ' Handle to VBA InputBox          KillTimer hwnd, idEvent            hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0&, "Edit", "")          If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If                       End Sub #End If


Share and enjoy.

Saturday 6 December 2014

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.



Tuesday 18 November 2014

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.

Tuesday 4 November 2014

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.



Thursday 18 September 2014

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