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