Private Sub cmdOK_Click()
On Error Resume Next
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim mySQL As String
Dim oApp As New Excel.Application
Dim oBook As Excel.Workbook
Dim oSheet As Excel.Worksheet
Set oBook = oApp.Workbooks.Add
Dim i, iNumCols As Integer
Dim frm As Form
Dim ctl As Control
Dim varItm As Variant
Set frm = Forms![Form1]
Set ctl = frm!lstQuery
lblMsg.Visible = True
If Len(txtLocation) > 0 Then
For Each varItm In ctl.ItemsSelected
txtLocation = ""
txtLocation = ctl.ItemData(varItm)
mySQL = "select * from tbInfo where Location='" & txtLocation & "'"
Set oSheet = oBook.Sheets.Add
oSheet.Name = txtLocation
lblMsg.Caption = "Ñang xuaát sang sheet: " & vbNewLine & txtLocation
Set db = CurrentDb
Set rs = db.OpenRecordset(mySQL, dbOpenSnapshot)
iNumCols = rs.Fields.Count
For i = 1 To iNumCols
With oSheet
.Cells(1, i).Value = rs.Fields(i - 1).Name
.Cells(1, i).Font.Bold = True
.Cells(1, i).Font.ColorIndex = 5
With .Cells(1, i).Interior
.ColorIndex = 34
End With
End With
Next
With oSheet
.Range("A2").CopyFromRecordset rs
.Columns("A:F").EntireColumn.AutoFit
End With
ctl.Selected(varItm) = False
txtLocation = ""
Next varItm
rs.Close
mySQL = "select Location, ADName, Sum(Amount) as Total from tbInfo Group by Location, adname"
Set oSheet = oBook.Sheets.Add
oSheet.Name = "Summary"
lblMsg.Caption = "Ñang xuaát sang sheet: " & vbNewLine & "Summary"
Set db = CurrentDb
Set rs = db.OpenRecordset(mySQL, dbOpenSnapshot)
iNumCols = rs.Fields.Count
For i = 1 To iNumCols
With oSheet
.Cells(1, i).Value = rs.Fields(i - 1).Name
.Cells(1, i).Font.Bold = True
.Cells(1, i).Font.ColorIndex = 5
With .Cells(1, i).Interior
.ColorIndex = 34
End With
End With
Next
With oSheet
.Range("A2").CopyFromRecordset rs
.Columns("A:F").EntireColumn.AutoFit
End With
For Each oSheet In oBook.Sheets
If Left(oSheet.Name, 5) = "Sheet" Then
oSheet.Delete
End If
Next oSheet
lblMsg.Visible = False
oApp.Visible = True
oApp.UserControl = True
rs.Close
db.Close
Else
Exit Sub
End If
End Sub
