HoangManh > 10-05-17, 11:01 AM
Private Sub In_Click()
'Dinh nghia cac bien
Dim Khach As Recordset
Set Khach = CurrentDb.OpenRecordset("tblKhach", dbOpenTable)
Dim Ex As Excel.Application
Dim Wb As Workbook
Dim Ws As Worksheet
Dim TenFile
'Xac dinh vi tri cac bien
TenFile = CurrentProject.Path & "\Danh sach khach hang.xls"
Set Ex = New Excel.Application
Set Wb = Ex.Workbooks.Open(TenFile)
Set Ws = Wb.Worksheets("Danh sach")
[color=#ff6633]k = Ws.Range("A65000").End(xlUp).Row[/color]
'Loc va chuyen du lieu ra Ex
If Khach.RecordCount = 0 Then MsgBox "Khong co du lieu de in", , "Xin loi": Exit Sub
Khach.MoveFirst
Do Until Khach.EOF
[color=#ff3333]n = Ws.Range("A65000").End(xlUp).Row[/color]
If Ws.Range("A" & n) = "STT" Then Ws.Range("A" & n + 1) = 1 Else Ws.Range("A" & n + 1) = Ws.Range("A" & n) + 1
Ws.Range("B" & n + 1) = Khach.Fields(0)
Ws.Range("C" & n + 1) = Khach.Fields(1)
Ws.Range("D" & n + 1) = Khach.Fields(2)
Khach.MoveNext
Loop
'Dinh dang File Ex
n = Ws.Range("A65000").End(xlUp).Row
Ws.Range("A" & k + 1 & ":B" & n).HorizontalAlignment = xlCenter
With Ws.Range("A" & k + 1 & ":D" & n)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
If n > k + 1 Then .Borders(xlInsideHorizontal).LineStyle = xlDot
End With
'Xoa bien, giai phong bo nho va cho Ex hien thi
Khach.Close
Ex.Visible = True
Set Ex = Nothing
End Subongke0711 > 10-05-17, 03:00 PM
HoangManh > 10-05-17, 03:54 PM
(10-05-17, 03:00 PM)ongke0711 Đã viết: - Báo lỗi .End(xlUp) là bạn tham chiếu thiết thư viện Excel. Bạn kiểm tra tham chiếu lại cho đúng đi. Microsoft Excel xx.x Object Library.
- Tôi thấy cái ví dụ này có đánh số thứ tự tự động rồi mà. Nếu bạn muốn bắt đầu =13 thì đổ ở dòng code này:
If Ws.Range("A" & n) = "STT" Then Ws.Range("A" & n + 1) = 13 Else …
Dim xlApp As Object 'Excel.Application
Dim xlSheet As Object 'Excel.Application
Dim xlBook As Object
Dim xlSheetCp As Object
Dim xlSheetBrk As Object
Dim lsPath As String
Dim lDb As Object
Dim lRs As Object
Dim lsSql As String
Dim lsStaffCd As String
Dim llCnt As Long
Dim llRow As Long
Dim liNO As Integer
Dim Subtotal As Integer
Dim Consumpitiontax As Integer
Dim Total As Integer
Dim Count As Integer
'On Error GoTo ErrProc
lsPath = CurrentProject.Path & "\納品書.xlsx"
If Dir(lsPath) = "" Then
MsgBox lsPath & " が存在しません。", vbCritical, "sgShiftPrint"
Exit Sub
End If
DoCmd.SetWarnings False
DoCmd.Hourglass True
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.UserControl = True
xlApp.Application.DisplayAlerts = False
lsSql = "SELECT GROUPNM, GROUPCD, TANNI, TNK, Sum(SEISANSU) AS SEISANSUの合計, Sum(KINGAKU) AS KINGAKUの合計, Max(SAGYOUDT) AS SAGYOUDTの最大"
lsSql = lsSql & " FROM WK_JI_G_SEISAN WHERE "
lsSql = lsSql & " IRO = 1 "
lsSql = lsSql & " GROUP BY GROUPNM, GROUPCD, TANNI, TNK"
lsSql = lsSql & ";"
Set xlBook = xlApp.Workbooks.Open(lsPath)
Set xlSheet = xlBook.Worksheets("Sheet1")
Set lDb = CurrentDb
Set lRs = lDb.OpenRecordset(lsSql)
lsStaffCd = vbNullString
llCnt = 0
llRow = 16
liNO = 1
Subtotal = 0
Count = 1
If lRs.EOF Then
MsgBox "データが存在しませんでした。", vbInformation, "sgShiftPrint"
GoTo ErrProc
End If
Set xlSheetCp = xlSheet
Set xlSheetBrk = xlSheet
Do Until lRs.EOF
If Count = 33 Then
Count = 1
llCnt = llCnt + 1
Set xlSheetCp = Nothing
llRow = 16
'シートコピー
xlSheetBrk.Copy after:=xlBook.Worksheets(llCnt)
'シート名変更
Set xlSheetCp = xlBook.Worksheets(llCnt)
xlSheetCp.Name = llCnt
'ヘッダ情報
xlBook.Worksheets(llCnt).Activate
End If
'ヘッダ情報
xlSheetCp.Range("B6") = Format(Me.txtSagyoust, "yyyy/mm") & "トッピング作業地"
xlSheetCp.Range("H6") = Date
xlSheetCp.Range("A" & llRow) = liNO
xlSheetCp.Range("B" & llRow) = "その他盛り付け作業" & "(" & fgNullToStr(lRs("GROUPNM").Value) & fgNullToNum(lRs("TNK").Value) & "円)"
xlSheetCp.Range("D" & llRow) = fgNullToNum(lRs("SEISANSUの合計").Value)
xlSheetCp.Range("E" & llRow) = fgNullToStr(lRs("TANNI").Value)
xlSheetCp.Range("F" & llRow) = fgNullToStr(lRs("TNK").Value)
xlSheetCp.Range("G" & llRow) = fgNullToNum(lRs("KINGAKUの合計").Value)
llRow = llRow + 1
liNO = liNO + 1
Count = Count + 1
'Subtotal = Subtotal + lRs.KINGAKUの合計
lRs.MoveNext
Loop
Set lRs = Nothing
Set lDb = Nothing
MsgBox "シフト表をデスクトップに、Excel出力しました。", vbInformation, "sgShiftPrint"
xlApp.Visible = True
xlBook.Saveas (GetDeskTopPass & "\納品書" & "_" & Format(Date, "yyyymmdd"))
xlBook.Close
xlApp.Quit
Set xlSheetCp = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
DoCmd.Hourglass False
DoCmd.SetWarnings True
Exit Sub