tracanhtam > 01-03-21, 11:02 AM
ongke0711 > 01-03-21, 12:37 PM
Dim firstRow As Long, recCount As Long, colCount As Long, lngR As Long, i As Integer
firstRow = 1 'Vị trí Cell đầu tiên bạn đổ dữ liệu cho nó'
recCount = rst.RecordCount
lngR = recCount
colCount = rst.Fields.Count
For i = 1 To colCount
Sht.Cells(recCount + 2, i).formulaR1C1 = "=SUM(R[-" & lngR & "]C:R[-1]C)"
Next i
tracanhtam > 02-03-21, 11:31 AM
ongke0711 > 02-03-21, 12:24 PM
(02-03-21, 11:31 AM)tracanhtam Đã viết: Bạn giúp dùm xuất report trên access ra file excel mà có sẳn công thức được không, xin cám ơn.
Link file :
https://drive.google.com/file/d/1rvWMvnq...sp=sharing
ongke0711 > 02-03-21, 04:42 PM
Option Compare Database
Option Explicit
Private Sub cmdXuatExcel_Click()
Dim sSourceName As String, sWorkbookPath As String
sSourceName = "qryXuatExcel"
sWorkbookPath = CurrentProject.Path & "\Xuat_report_excel.xltx"
Call DataToExcel(sSourceName, sWorkbookPath)
End Sub
Function DataToExcel(strSourceName 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 firstRow As Long, recCount As Long, colCount As Long, i As Integer
'Table/Query
Set rst = CurrentDb.OpenRecordset(strSourceName)
'Tao môt phiên lam viec Excel khác.
Set excelApp = CreateObject("Excel.Application")
On Error Resume Next
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
Set Sht = Wbk.Worksheets("BaoCao")
excelApp.Visible = True
On Error GoTo ErrorHandler
rst.MoveFirst
Sht.Range("B7").CopyFromRecordset rst
firstRow = 7
recCount = rst.RecordCount
colCount = rst.Fields.Count
Sht.Cells(recCount + firstRow, 2).Value = "T" & ChrW(7893) & "ng c" & ChrW(7897) & "ng:"
Sht.Cells(recCount + firstRow, 2).HorizontalAlignment = -4108
Sht.Cells(recCount + firstRow, 2).Font.Bold = True
For i = 3 To colCount + 1
Sht.Cells(recCount + firstRow, i).FormulaR1C1 = "=SUM(R[-" & recCount & "]C:R[-1]C)"
Sht.Cells(recCount + firstRow, i).Font.Bold = True
Next i
For i = firstRow To recCount + firstRow - 1
Sht.Cells(i, 20).FormulaR1C1 = "=SUM(RC[-17]:RC[-1])"
Sht.Cells(i, 24).FormulaR1C1 = "=RC[-4]-RC[-3]"
Sht.Cells(i, 25).FormulaR1C1 = "=RC[-2]+RC[-1]"
Next i
'Danh STT
For i = 1 To recCount
Sht.Cells(i + firstRow - 1, 1).Value = i
Next i
'Ke border cho bang
Set xlRng = Sht.Range("A7:Y" & recCount + firstRow)
With xlRng
With .Borders
.ColorIndex = -4105 'xlAutomatic
.LineStyle = 1 'xlContinuous
.Weight = 2 'xlThin
End With
End With
'Dinh dang Number
Set xlRng = Sht.Range("C7:Y" & recCount + firstRow)
With xlRng
.NumberFormat = "0"
.HorizontalAlignment = xlRight
End With
'Them Text
Sht.Cells(recCount + firstRow + 2, 20).Value = "M" & ChrW(7929) & " Tho, " & "Ngày " & Day(Date) & " Tháng " & Month(Date) & " N" & ChrW(259) & "m " & Year(Date)
Sht.Cells(recCount + firstRow + 2, 20).HorizontalAlignment = -4108
Sht.Cells(recCount + firstRow + 3, 20).Value = "T" & ChrW(7893) & " Tr" & ChrW(432) & ChrW(7903) & "ng"
Sht.Cells(recCount + firstRow + 3, 20).Font.Bold = True
Sht.Cells(recCount + firstRow + 3, 20).HorizontalAlignment = -4108
Sht.Cells(1, 1).Select
rst.Close
Set rst = Nothing
Exit Function
ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation
End Function
tracanhtam > 04-03-21, 12:45 PM
(02-03-21, 04:42 PM)ongke0711 Đã viết: Bạn xem file.
Link: https://www.mediafire.com/file/hhm99qx62...l.rar/file
Code:
Mã PHP:Option Compare Database
Option Explicit
Private Sub cmdXuatExcel_Click()
Dim sSourceName As String, sWorkbookPath As String
sSourceName = "qryXuatExcel"
sWorkbookPath = CurrentProject.Path & "\Xuat_report_excel.xltx"
Call DataToExcel(sSourceName, sWorkbookPath)
End Sub
Function DataToExcel(strSourceName 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 firstRow As Long, recCount As Long, colCount As Long, i As Integer
'Table/Query
Set rst = CurrentDb.OpenRecordset(strSourceName)
'Tao môt phiên lam viec Excel khác.
Set excelApp = CreateObject("Excel.Application")
On Error Resume Next
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
Set Sht = Wbk.Worksheets("BaoCao")
excelApp.Visible = True
On Error GoTo ErrorHandler
rst.MoveFirst
Sht.Range("B7").CopyFromRecordset rst
firstRow = 7
recCount = rst.RecordCount
colCount = rst.Fields.Count
Sht.Cells(recCount + firstRow, 2).Value = "T" & ChrW(7893) & "ng c" & ChrW(7897) & "ng:"
Sht.Cells(recCount + firstRow, 2).HorizontalAlignment = -4108
Sht.Cells(recCount + firstRow, 2).Font.Bold = True
For i = 3 To colCount + 1
Sht.Cells(recCount + firstRow, i).FormulaR1C1 = "=SUM(R[-" & recCount & "]C:R[-1]C)"
Sht.Cells(recCount + firstRow, i).Font.Bold = True
Next i
For i = firstRow To recCount + firstRow - 1
Sht.Cells(i, 20).FormulaR1C1 = "=SUM(RC[-17]:RC[-1])"
Sht.Cells(i, 24).FormulaR1C1 = "=RC[-4]-RC[-3]"
Sht.Cells(i, 25).FormulaR1C1 = "=RC[-2]+RC[-1]"
Next i
'Danh STT
For i = 1 To recCount
Sht.Cells(i + firstRow - 1, 1).Value = i
Next i
'Ke border cho bang
Set xlRng = Sht.Range("A7:Y" & recCount + firstRow)
With xlRng
With .Borders
.ColorIndex = -4105 'xlAutomatic
.LineStyle = 1 'xlContinuous
.Weight = 2 'xlThin
End With
End With
'Dinh dang Number
Set xlRng = Sht.Range("C7:Y" & recCount + firstRow)
With xlRng
.NumberFormat = "0"
.HorizontalAlignment = xlRight
End With
'Them Text
Sht.Cells(recCount + firstRow + 2, 20).Value = "M" & ChrW(7929) & " Tho, " & "Ngày " & Day(Date) & " Tháng " & Month(Date) & " N" & ChrW(259) & "m " & Year(Date)
Sht.Cells(recCount + firstRow + 2, 20).HorizontalAlignment = -4108
Sht.Cells(recCount + firstRow + 3, 20).Value = "T" & ChrW(7893) & " Tr" & ChrW(432) & ChrW(7903) & "ng"
Sht.Cells(recCount + firstRow + 3, 20).Font.Bold = True
Sht.Cells(recCount + firstRow + 3, 20).HorizontalAlignment = -4108
Sht.Cells(1, 1).Select
rst.Close
Set rst = Nothing
Exit Function
ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation
End Function