Creating Long SQL strings with Arrays

If you've ever created an long SQL string for a Pivot Table or some other reason, you will have come across Excel's limitations in this area. For example, you cannot have too many line continuations ( _ ). Also, if you have used the macro recorder while getting External Data through MS Query, there is some limitation there too. It will not actually record all the SQL, but cuts it off half way through.

The way the recorder works when getting data for a Pivot Table is interesting and I thought I'd use it in my code in a different way. It creates an array of arrays like this:

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 28/06/2005 by A
'

'
    With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
        .Connection = Array(Array( _
        "ODBC;DSN=Xtreme Sample Database 2003;DBQ=C:\Program Files\Microsoft Visual Studio .NET 2003\Crystal Reports\Samples\Database\xtreme." _
        ), Array("mdb;DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;"))
        .CommandType = xlCmdSql
        .CommandText = Array( _
        "SELECT Employee.`Employee ID`, Employee.`Supervisor ID`, Employee.`Last Name`, Employee.`First Name`, Employee.Position, Employee.`Birth Date`, Employee.`Hire Date`, Employee.`Home Phone`, Employee.Ex" _
        , _
        "tension, Employee.Photo, Employee.Notes, Employee.`Reports To`, Employee.Salary, Employee.SSN, Employee.`Emergency Contact First Name`, Employee.`Emergency Contact Last Name`, Employee.`Emergency Cont" _
        , _
        "act Relationship`, Employee.`Emergency Contact Phone`" & Chr(13) & "" & Chr(10) & "FROM Employee Employee" _
        )
        .CreatePivotTable TableDestination:="[Book1]Sheet1!R3C1", TableName:= _
        "PivotTable1", DefaultVersion:=xlPivotTableVersion10
    End With
    
    'do stuff with pivot tables
    
End Sub

It's a bit messy so I thought I'd clean it up. I used the array idea by adding bits of the string into the next element of a growing array, and then joining the array using the Join Function (opposite of Split).

Sub Macro1Redo()

    Dim ssql As String
    Dim sConn As String

    'create the array string
    Call AddToArray(ssql, "SELECT Employee.Employee ID, Employee.Supervisor ID, Employee.Last Name,")
    Call AddToArray(ssql, "Employee.First Name, Employee.Position, Employee.Birth Date, ")
    Call AddToArray(ssql, "Employee.Hire Date,Employee.Home Phone, Employee.Extension,")
    Call AddToArray(ssql, "Employee.Photo, Employee.Notes, Employee.Reports To,")
    Call AddToArray(ssql, "Employee.Salary, Employee.SSN, Employee.Emergency Contact First Name,")
    Call AddToArray(ssql, "Employee.Emergency Contact Last Name, Employee.Emergency Contact Relationship,")
    Call AddToArray(ssql, "Employee.Emergency Contact Phone ")
    Call AddToArray(ssql, "FROM Employee")
    
    'join the strings back together
    ssql = Join(ssql)
    
    Call AddToArray(sConn, "ODBC;DSN=Xtreme Sample Database 2003;")
    Call AddToArray(sConn, "DBQ=C:\Program Files\Microsoft Visual Studio .NET 2003\")
    Call AddToArray(sConn, "Crystal Reports\Samples\Database\xtreme.mdb;")
    Call AddToArray(sConn, "DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;")

    'join the strings back together
    sConn = Join(sConn)

    With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal)
        .Connection = sConn
        .CommandType = xlCmdSql
        .CommandText = ssql
        .CreatePivotTable TableDestination:="[Book1]Sheet1!R3C1", TableName:= _
        "PivotTable1", DefaultVersion:=xlPivotTableVersion10
    End With
    
    'do stuff with pivot tables
    
End Sub


Sub AddToArray(myArray As Variant, arrayElement As Variant)

If Not IsArrayInitialized(myArray) Then
    ReDim myArray(0)
    myArray(0) = arrayElement
Else
    ReDim Preserve myArray(UBound(myArray) + 1)
    myArray(UBound(myArray)) = arrayElement
End If

End Sub

Using Randomization in Battleship Game

There are a set of challenges at http://www.xl-logic.com/pages/challenge.html and I thought I'd give the Battleship Challenge a go. It involves the use of random numbers to fill a Battleship board without the ships falling off the board or overlapping each other. I used colours to represent the ships. There was an extra challenge to use shapes for the ships. I tried this out, but could not get the vertical ships to line up correctly. The cell.top and .left and shape.top and .left properties seem to be out of sync when you rotate an auto shape by 90 degress. Maybe someone has a solution? You can download the workbook here.

Removing Broken References and Adding VBA References

A user had a question about my Controlling Outlook From Excel post.

I have been reading your homepage and I have a problem with my macro. It works
fine when the Microsoft Outlook Object Library is checked as reference.
But my file is to be executed on 67 different PCs and they have not (many of them)
any reference marked to Outlook. And if the reference to outlook is not marked
in advance, then the macro doesn’t run – but displays a compile error.

I have tried this with both Early and Late Binding.

Do you know a method where the macro by itself find the outlook version and automatically set the references?

I had the same problem, as I take a workbook of mine home and there are different versions of Outlook. When I returned to work, there was always a broken reference to Outlook 11 (2003).

The following code runs fine on my machine but I do not have any broken references at the moment. Note that the Auto_Open routine along with the rest of the code needs to be in a standard module. Auto_Open runs before the Workbook_Open event. Thanks to a comment from Rob van Gelder for the major and minor version code.

Note that there needs to be a reference to “Microsoft Visual Basic for Applications Extensibility 5.3? for this code to work.

Sub Auto_Open()

Call RemoveOutlookReferences
Call LoadOutlookReferences

End Sub

Sub LoadOutlookReferences()

'load Outlook object library
On Error Resume Next
'When using AddFromGUID, you can use zero for the major
'and minor versions to pick the latest.

'adding VBE object library:
ActiveWorkbook.VBProject.References.AddFromGuid _
"{0002E157-0000-0000-C000-000000000046}", 0, 0
'Adding outlook object library:
Application.VBE.ActiveVBProject.References _
.AddFromGuid "{00062FFF-0000-0000-C000-000000000046}", 0, 0
On Error GoTo 0

End Sub

Function ReferenceIsBroken(sRef As String) As Boolean

Dim vbProj As VBProject ' This refers to your VBA project.
Dim chkRef As Reference ' A reference.

' Refer to the VBA project.
Set vbProj = ThisWorkbook.VBProject

' Check through the selected references in the References dialog box.
For Each chkRef In vbProj.References

If sRef = chkRef.Name And chkRef.IsBroken Then

'if the ref matches the found ref and it is broken
ReferenceIsBroken = True
Exit Function

End If

Next

ReferenceIsBroken = False

End Function

Sub RemoveOutlookReferences()


Dim liCnt As Integer
Dim sRef As String
Dim count
Dim sThisVBEName As String
Const OUTLOOK_REF As String = "OUTLOO"

sThisVBEName = ThisWorkbook.VBProject.Name

'' Remove references to Outlook if they are there and are broken
For liCnt = Application.VBE.VBProjects.Item(sThisVBEName).References.count To 1 Step -1
sRef = UCase(Left(Application.VBE.VBProjects.Item(sThisVBEName).References.Item(liCnt).Name, 6))

Debug.Print sRef

If sRef = OUTLOOK_REF And ReferenceIsBroken(sRef) Then

Application.VBE.VBProjects.Item(sThisVBEName).References.Remove Application.VBE.VBProjects.Item(sThisVBEName).References.Item(liCnt)

End If
Next liCnt

End Sub

Updated FaceIDs program

Some time ago, John Walkenbach at JWalk came up with an addin to show FaceIDs and their Control IDs.

Check out http://www.j-walk.com/ss/excel/tips/tip67.htm to see his version.

Incidentally, he said that I can do whatever I like with it because his PUP add-in has a MUCH better tool for identifying FaceIDs.

I have been using the original FaceID xla a fair bit in my work and have adapted it slightly. The reason I changed it is because most of the time, the FaceIDs are invalid for use on the menu, and I wanted to be able to see this when browsing the UserForm. Whenever the FaceID is invalid, the FaceID number will be black instead of the normal yellow. Download my version here.

Email me if you want a version for Excel 2003.

Check out the JWalk's site for install instructions.

Automatic Mouse Movement on UserForms

I have been using an Excel addin which I had need to automate some
procedures overnight. There are a number a userforms which
have certain commandbuttons to click. Unfortunately, you cannot
access the Command Button click event from external code.

So I searched far and wide for a solution. I found the MouseMove API
routine and adapted it for VBA Userforms.

The principle is that you obtain and enter the dimensions of the UserForm
and Control that you want to access, and then the mouse moves
by itself to that location after a predetermined delay.

Here is a sample file to download if you wish to try it. Open the workbook, click the Start command button and a UserForm is shown. The mouse will click the command UserForm's button automatically.

Controlling Outlook from Excel

I needed to be able to email a sheet or a workbook to Outlook after
running some code on the sheet to strip the code, formulas etc. The
built in Excel Send To dialog just send the workbook or sheet as is.
I have attached the code for controlling outlook. all you need to do is
manipulate your workbook and set the wbname variable to be your
Workbook name.

To send one sheet only, copy your sheet to another
workbook first and delete the default sheets.

Sub MailToOutlook()
'notes:
'You need a reference to the Outlook library by
'going to Tools > References and finding
'the outlook library
'if you open this with a computer with outlook 2003
', the reference will change
'to Outlook 11 library, compared to Outlook 2000
'which will refer an outlook 9 library


wbname = ThisWorkbook.FullName

Dim objol As New Outlook.Application
Dim objmail As MailItem
Set objol = New Outlook.Application
Set objmail = objol.createitem(olmailitem)

    With objmail
        'enter email address
        .To = "andrew@excelthoughts.com"
        '.cc = "whoever" 'enter e email address
        .Subject = "Email"
        .Body = "Please find the attached file"
        .NoAging = True
        'adds attachment to email
        .Attachments.Add wbname
        .display
    End With
  
    'destroy objects
    Set objmail = Nothing
    Set objol = Nothing
  
End Sub

Find Text in Hidden Cells

Hi! This is my first ever post, so bear with me as I find my feet.

Excel's Find functionality is getting better as they release new versions, but there is still nothing that will allow you to search through hidden cells for text. I have included a snapshot of code that adds this functionality to the Find function.

To use it, copy the code into a module and type "FindThis" onto a sheet, hide the row or column and run the FindhiddenText routine. This code can be customised quite a lot e.g. Find All, Find on Multiple sheets etc.

Option Explicit

Public Function AdvancedFind(rToSearch As Range, _
sToFind As String) As Range

Dim rFound As Range
Dim rHiddenCols As Range
Dim rHiddenRows As Range

'unhide cols/rows
Set rHiddenCols = UnHideColumns(rToSearch)
Set rHiddenRows = UnHideRows(rToSearch)

Set rFound = rToSearch.Find(what:=sToFind)

'hide cols/rows
Call HideRowsAndColumns(rHiddenCols, rHiddenRows)

Set AdvancedFind = rFound

End Function

Sub HideRowsAndColumns(rHiddenCols As Range, _
rHiddenRows As Range)

Dim r As Range

    If Not rHiddenCols Is Nothing Then
        For Each r In rHiddenCols.Columns
            r.Columns.Hidden = True
        Next r
    End If
        
    If Not rHiddenRows Is Nothing Then
        rHiddenRows.Rows.Hidden = True
    End If
    

End Sub

Sub FindHiddenText()

Dim r As Range
Dim text As String

text = "FindThis"

Set r = AdvancedFind(ActiveSheet.Cells, text)

'display message
If Not r Is Nothing Then
    MsgBox "Found " & text & " at " & r.Address
Else
    MsgBox text & " not found"
End If

End Sub

Function UnHideColumns(rToSearch As Range) As Range

'''''''''''''''''''''
Dim c As Range
Dim rHiddenCols As Range

Set rHiddenCols = Nothing

For Each c In rToSearch.Columns
    If c.Hidden = True Then
        'unhide col
        c.Hidden = False
        
        'add to union range
        If rHiddenCols Is Nothing Then
            Set rHiddenCols = c
        Else
            Set rHiddenCols = Union(rHiddenCols, c)
        End If
    End If
Next c

Set UnHideColumns = rHiddenCols




End Function


Function UnHideRows(rToSearch As Range) As Range

'''''''''''''''''''''
Dim c As Range
Dim rHiddenRows As Range

Set rHiddenRows = Nothing

For Each c In rToSearch.Rows
    If c.Hidden = True Then
        'unhide col
        
        'add to union range
        If rHiddenRows Is Nothing Then
            Set rHiddenRows = c
        Else
            Set rHiddenRows = Union(rHiddenRows, c)
        End If
    
    
    End If
Next c

If Not rHiddenRows Is Nothing Then
    rHiddenRows.Rows.Hidden = False
End If


Set UnHideRows = rHiddenRows


End Function