doandinhtam > 24-06-22, 05:37 PM
ongke0711 > 24-06-22, 05:58 PM
doandinhtam > 25-06-22, 09:54 AM
ongke0711 > 25-06-22, 03:30 PM
(25-06-22, 09:54 AM)doandinhtam Đã viết: Mình tìm nhưng không thấy ongke ơi. Bạn có file tham khảo không cho mình xin file ạ
sSQL = Select * From tblABC"
...
...
Call DataToExcel (sSQL)Function DataToExcel(sSQL As String, Optional strWorkbookPath As String, Optional strTargetSheetName As String)
Dim rst As DAO.Recordset
Dim excelApp As Object
Dim Wbk As Object
Dim Sht As Object
Dim xlRng As Object
Dim fldHeadings As DAO.Field
'Lay du lieu cho recordset (table hoac query).
Set rst = CurrentDb.OpenRecordset(sSQL)
'Tao phiên làm viec Excel moi.
Set excelApp = CreateObject("Excel.Application")
On Error Resume Next
'Try to open the specified workbook. If there is no workbook specified
'(or if it cannot be opened) create a new one and rename the target sheet.
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
If Err.Number <> 0 Or Len(strWorkbookPath) = 0 Then
Set Wbk = excelApp.Workbooks.Add
Set Sht = Wbk.Worksheets("Sheet1")
If Len(strTargetSheetName) > 0 Then
Sht.Name = Left(strTargetSheetName, 34)
End If
End If
'If the specified workbook has been opened correctly, then in order to avoid
'problems with other sheets that might contain, a new sheet is added and is
'being renamed according to the strTargetSheetName.
Set Sht = Wbk.Worksheets.Add
If Len(strTargetSheetName) > 0 Then
Sht.Name = Left(strTargetSheetName, 34)
End If
On Error GoTo 0
excelApp.Visible = True
On Error GoTo ErrorHandler
'Copy dòng tiêu de.
For Each fldHeadings In rst.Fields
excelApp.ActiveCell = fldHeadings.Name
excelApp.ActiveCell.Offset(0, 1).Select
Next
'Copy du lieu xuong sheet.
rst.MoveFirst
Sht.range("A2").Select
Sht.range("A2").CopyFromRecordset rst
Sht.range("1:1").Select
'Dinh dang dòng tiêu de.
excelApp.Selection.Font.Bold = True
With excelApp.Selection
.HorizontalAlignment = -4108 '= xlCenter in Excel.
.VerticalAlignment = -4108 '= xlCenter in Excel.
.WrapText = False
End With
Set xlRng = Sht.UsedRange
With xlRng
.Font.Name = "Verdana"
.Font.Size = 8
With .Borders
.ColorIndex = -4105 'xlAutomatic
.LineStyle = 1 'xlContinuous
.Weight = 2 'xlThin
End With
With .Rows(1)
.Font.Bold = True
.Interior.ColorIndex = 15
End With
.WrapText = False
.EntireColumn.AutoFit
End With
excelApp.ActiveSheet.Cells.EntireColumn.AutoFit
With excelApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
End With
Sht.Rows("2:2").Select
excelApp.ActiveWindow.FreezePanes = True
With Sht
.Tab.Color = RGB(255, 0, 0)
.range("A1").Select
End With
rst.Close
Set rst = Nothing
Exit Function
ErrorHandler:
Msgbox "Ma loi: " & Err.Number & vbNewLine & "Noi dung loi: " & Err.Description, vbExclamation, "Thong bao"
Exit Function
End Function