Export SQL query results to Excel report

Private Sub cmdExportToExcel_Click()
   Dim lI As Long
   Dim rsData As New adodb.Recordset
   Dim sSql As String
   
   
'   Dim xlApp As New Excel.Application
'   Dim xlWorkbook As Excel.Workbook
'   Dim xlSheet As Excel.Worksheet
   
   Dim xlApp As Object
   Set xlApp = CreateObject("Excel.Application")
   Dim xlWorkbook As Object
   Dim xlSheet As Object
   
   
   cmdExportToExcel.Enabled = False
   xlApp.Visible = True
   sSql = txtQuery.Text
   rsData.Open sSql, cnConnect, adOpenStatic
   If rsData.EOF = False Then
      'Data was retured from query
      Set xlWorkbook = xlApp.Workbooks.Add
      Set xlSheet = xlWorkbook.Sheets.Add
      xlSheet.Name = "Report"
      
      For lI = xlWorkbook.Worksheets.Count To 1 Step -1
         If xlWorkbook.Worksheets(lI).Name <> "Report" Then
            'Remove any sheets created by default (Sheet1, Sheet2, Sheet3, etc)
            xlWorkbook.Worksheets(lI).Delete
         End If
      Next lI
      
      xlSheet.Range("A4").CopyFromRecordset rsData
      'Copy the recordset to Excel
      
      For lI = 0 To rsData.Fields.Count - 1
         xlSheet.Cells(3, lI + 1).Value = rsData.Fields(lI).Name
         'Put the name of each colum on the top row
      Next lI
      
      xlSheet.Rows(3).EntireRow.Font.Bold = True
      'Make header row bold
      
      xlSheet.Columns.Font.Name = "Verdana"
      xlSheet.Columns.Font.Size = 12
      
      xlSheet.Range("A1").Value = Now
      'Put the date and time in the upper left corner

      xlSheet.Activate
      If xlSheet.Application.WindowState <> Excel.XlWindowState.xlNormal Then
         'Cells cannot be merged when the window is minimized, so don't let it be minimized
         xlSheet.Application.WindowState = Excel.XlWindowState.xlNormal
      End If
      
      xlSheet.Range(xlSheet.Cells(2, 1), xlSheet.Cells(2, rsData.Fields.Count)).Merge
      'Combine the report name cells for centering
      xlSheet.Range("A2").Value = "Report Name"
      xlSheet.Range("A2").HorizontalAlignment = Excel.XlHAlign.xlHAlignCenter
      xlSheet.Range("A2").EntireRow.Font.Bold = True
      
      xlSheet.UsedRange.Columns.AutoFit
      'Expand all cells to the size of the data
      xlSheet.Rows(1).Show
      'Move to the top of the sheet
      xlSheet.Rows(1).Select
      'Set up spreadsheet to freeze header row
      xlApp.ActiveWindow.SplitColumn = 0
      xlApp.ActiveWindow.SplitRow = 3
      'Freeze header row so it remains visible when scrolling data
      xlApp.ActiveWindow.FreezePanes = True
   
      xlSheet.PageSetup.PrintTitleRows = "$1:$4"
      'Keep the header rows visible when printing
      xlSheet.PageSetup.Zoom = False
      xlSheet.PageSetup.FitToPagesTall = False
      xlSheet.PageSetup.FitToPagesWide = 1
      'Scale the printout so all the columns can be seen
   End If
   rsData.Close
   
   cmdExportToExcel.Enabled = True
End Sub

Type to select on a Combo Box

Private Sub cboGroup_GotFocus()
   Dim cboTTS As ComboBox
   Set cboTTS = cboGroup
   cboTTS.Tag = ""
   'Initialize the string of characters typed while on this control
   cboTTS.ToolTipText = ""
End Sub

Private Sub cboGroup_KeyPress(KeyAscii As Integer)
   Dim txtTTS As TextBox
   Set txtTTS = Me.ActiveControl
   
   'The code in the GotFocus() and KeyUp() events are needed to make this code work
   'The following line is required in the form's General Declarations:
   'Public dicPublicList As Object
   'Before this code is invoked, the dictionary must be populated like:
   'Set dicPublicList = CreateObject("Scripting.Dictionary")
   'dicPublicList.RemoveAll
   'dicPublicList.Add "Key1", "ValueOne"
   'dicPublicList.Add "Key2", "ValueTwo"
   'dicPublicList.Add "Key3", "ValueThree"
   
   If dicPublicList.Count < 1 Then
      Exit Sub
   End If
   txtTTS.Locked = True
   'Lock the text box during this subroutine or it won't work right
   Dim lI As Long
   If KeyAscii = 91 Then
      'User typed a [ character, which is a problem for the LIKE command used later, replace it with a ? character
      KeyAscii = 63
   End If
   If KeyAscii = 8 And Len(CStr(txtTTS.Tag)) > 0 Then
      'User typed a backspace
      txtTTS.Tag = Left(CStr(txtTTS.Tag), Len(CStr(txtTTS.Tag)) - 1)
      'Remove the latest character from the string of characters typed while on this control
      txtTTS.SelStart = Len(CStr(txtTTS.Tag))
      'Show how many characters have been typed
      txtTTS.SelLength = Len(CStr(txtTTS.Text))
      'Highlight the rest of the selected item
      txtTTS.ToolTipText = txtTTS.Tag
   End If
   If KeyAscii > 31 Then
      'The user did not type a control character
      txtTTS.Tag = CStr(txtTTS.Tag) + Chr(KeyAscii)
      'Add the character to the string of characters typed while on this control
      txtTTS.ToolTipText = txtTTS.Tag
      For lI = 1 To dicPublicList.Count
         'Look at each item in the dictionary
         If CStr(dicPublicList.Item(lI)) Like CStr(txtTTS.Tag) & "*" Then
            'The item starts with the same characters as those typed
            'Option Compare Text must be done on this form's general declarations
            txtTTS.Text = dicPublicList(lI)
            'Show the text of the item
            txtTTS.SelStart = Len(CStr(txtTTS.Tag))
            'Show how many characters have been typed
            txtTTS.SelLength = Len(CStr(txtTTS.Text))
            'Highlight the rest of the selected item
            Exit Sub
            'Stop looking at items
         End If
      Next lI
      txtTTS.Tag = Left(CStr(txtTTS.Tag), Len(CStr(txtTTS.Tag)) - 1)
      'Nothing matches, so remove this character from the string of characters typed
      txtTTS.ToolTipText = txtTTS.Tag
   End If
End Sub

Private Sub cboGroup_KeyUp(KeyCode As Integer, Shift As Integer)
   Dim cboTTS As ComboBox
   Set cboTTS = cboGroup
   cboTTS.Locked = False
   'Unlock the combo box so items can be selected with the mouse
End Sub

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Pawz(Seconds As Double)
   Dim EndDateTime As Date
   EndDateTime = DateAdd("s", Seconds, Now)
   While Now < EndDateTime
   DoEvents
      Sleep 18
   Wend
End Sub