Nhờ giúp đỡ code chuyển Reports sang Excel

Trang chủ click to expand contents
Nhờ giúp đỡ code chuyển Reports sang Excel
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

MTNQ > 24-03-14, 05:43 PM

Nghe thì có vẻ đơn giản nhưng làm thì mới thấy khá rắc rối

-Để viết được chữ "Tổng:" vào file excel với VBA cần sử dụng hàm hỗ trợ Unicode hoặc lưu chữ "Tổng:" vào một bảng nào đó như trong các chủ đề về hiển thị thông báo bằng Tiếng Việt
Ở đây mình vẽ một label trên form với nhãn (Caption) là "Tổng:" rồi gán thuộc tính visible = false sau đó dùng một biến làm "xe" rước hắn vào file excel

Đây là yêu cầu của bạn mình đưa lên đây để mọi người cùng tham khảo: Download

Có nhiều cách để làm được như file Vidu, mình đưa ra hai cách bạn xem thử nhé

DemoXuatExcel3.rar

Code1 (Click to View)

Mã:
Private Sub Command0_Click() On Error GoTo Err_Command0_Click Dim xlApp As Excel.Application Dim wb As Workbook Dim tong As String, strPath As String Dim i As Integer, j As Integer, n As Integer Dim FinalRowB As Integer, FinalRowC As Integer strPath = "C:\Vidu.xls" DoCmd.RunMacro "Macro1" tong = Forms!form1!lbltong.Caption Set xlApp = New Excel.Application Set wb = xlApp.Workbooks.Open(strPath) With wb.Worksheets(1) .Select n = .Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count FinalRowC = .Cells(.Rows.Count, 3).End(xlUp).Row j = 1 i = 0 For x = 3 To FinalRowC + (n * 2) ThisValue = .Cells(x, 3).Value If ThisValue <> "" Then .Cells(x, 2).Value = j i = 0 Else If .Cells(x, 2).Value = "" Then i = 0 If i = 0 And .Cells(x, 2).Value <> "" Then .Rows(x).EntireRow.Insert Shift:=xlDown .Cells(x, 2).Value = tong i = i + 1 End If j = 0 End If j = j + 1 Next x FinalRowB = .Cells(.Rows.Count, 2).End(xlUp).Row FinalRowC = .Cells(.Rows.Count, 3).End(xlUp).Row If FinalRowB > FinalRowC Then .Cells(FinalRowB + 1, 2).Value = tong Else .Cells(FinalRowC + 1, 2).Value = tong End If End With For i = 1 To 16 wb.Worksheets(1).Rows("1:1").Insert Shift:=xlDown 'Chèn thêm vào 16 dòng Next i wb.Worksheets(1).Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cot wb.Worksheets(1).Columns.EntireRow.AutoFit xlApp.Visible = True 'Hien file excel lên Set wb = Nothing Set xlApp = Nothing Exit_Command0_Click: Exit Sub Err_Command0_Click: If Not xlApp Is Nothing Then xlApp.Quit Set xlApp = Nothing End If MsgBox Err.Description Resume Exit_Command0_Click End Sub

Code2 (Click to View)

Mã:
Private Sub Command2_Click() On Error GoTo Err_Command2_Click Dim xlApp As Excel.Application Dim wb As Workbook Dim strPath As String Dim j As Byte Dim tong As String Dim Rng As Range strPath = "C:\Vidu.xls" DoCmd.RunMacro "Macro2" tong = Forms!form1!lbltong.Caption Set xlApp = New Excel.Application Set wb = xlApp.Workbooks.Open(strPath) With wb.Worksheets(1) .Select FinalRow = .Cells(.Rows.Count, 3).End(xlUp).Row For x = 2 To FinalRow ThisValue = .Cells(x, 3).Value If ThisValue <> "" Then .Cells(x, 2).Value = ThisValue End If Next x End With wb.Worksheets(1).Range("C:C").EntireColumn.Delete Set Rng = wb.Worksheets(1).Columns("B:B").SpecialCells(xlCellTypeConstants) For Each Cls In Rng 'If Cls.Font.Color = vbRed Then Cls.Value = tong If Cls.HorizontalAlignment = xlRight Then Cls.Value = tong Cls.Font.Color = vbBlack Cls.HorizontalAlignment = xlLeft End If Next Cls For i = 1 To 16 wb.Worksheets(1).Rows("1:1").Insert Shift:=xlDown 'Chèn thêm vào 16 dòng Next i wb.Worksheets(1).Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cot wb.Worksheets(1).Columns.EntireRow.AutoFit xlApp.Visible = True 'Hien file excel lên Set wb = Nothing Set xlApp = Nothing Set Rng = Nothing Exit_Command2_Click: Exit Sub Err_Command2_Click: If Not xlApp Is Nothing Then xlApp.Quit Set xlApp = Nothing End If MsgBox Err.Description Resume Exit_Command2_Click End Sub
Thực ra mình cảm thấy hai cách trên cũng chưa thực sự tối ưu
Về VBA trong Excel nội công mình cũng kém lắm, bạn nào có cách hay hơn thì góp ý nha

P/s: mình vừa sửa code (bổ sung thêm chút xíu) và đã up lại link, thời điểm sửa bài cập nhật phía trên bài viết.
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

MTNQ > 26-03-14, 08:19 AM

Nhờ câu hỏi của bạn, tối qua "bế quan luyện công" Excel, lên được đến tầng thứ... 2

Code của hai cách trên mình rút gọn được như sau:
(Có ghi chú cho các câu lệnh để các bạn có thể tham khảo và tùy biến)

Code1: Rút gọn từ 2 vòng lặp xuống còn 1 (Click to View)

Mã:
Private Sub Command0_Click() On Error GoTo Err_Command0_Click Dim xlApp As Excel.Application Dim wb As Workbook Dim tong As String, strPath As String Dim i As Long, j As Long, n As Long Dim FinalRow As Long Dim B_i strPath = "C:\Vidu.xls" DoCmd.RunMacro "Macro1" tong = Forms!form1!lbltong.Caption Set xlApp = New Excel.Application Set wb = xlApp.Workbooks.Open(strPath) With wb.Worksheets(1) .Select 'Dem so dong co du lieu trong cot B n = .Columns("B:B").SpecialCells(xlCellTypeConstants).Count 'Dem so dong co trong cac Group FinalRow = .UsedRange.Row + .UsedRange.Rows.Count - 1 'Them chu "To^ng:" vao dong cuoi cung .Cells(FinalRow + 1, 2).Value = tong j = 1 For i = 3 To FinalRow + n B_i = .Cells(i, 2).Value If .Cells(i, 3).Value <> "" Then 'Neu dong thu i trong cot C co du lieu thi: .Cells(i, 2).Value = j 'Danh so thu tu vao cot B BValue = "" Else If B_i <> BValue And B_i <> "" And B_i <> tong Then .Rows(i).EntireRow.Insert Shift:=ilDown 'Chen them dong .Cells(i, 2).Value = tong 'Them chu "Tong:" vao dong vua chen BValue = B_i End If j = 0 End If j = j + 1 Next i .Rows("1:16").Insert Shift:=xlDown 'Chèn vào 16 dòng tren dau trang .Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cac cot .Columns.EntireRow.AutoFit 'Tu dong chinh chieu cao cac dong End With xlApp.Visible = True 'Hien file excel lên Set wb = Nothing 'Huy bien doi tuong va giai phong bo nho Set xlApp = Nothing Exit_Command0_Click: Exit Sub Err_Command0_Click: If Not xlApp Is Nothing Then xlApp.Quit Set xlApp = Nothing End If MsgBox Err.Description Resume Exit_Command0_Click End Sub

Code2: Rút gọn từ 3 vòng lặp xuống còn 1 (Click to View)

Mã:
Private Sub Command2_Click() On Error GoTo Err_Command2_Click Dim xlApp As Excel.Application Dim wb As Workbook Dim strPath As String Dim j As Byte Dim tong As String Dim Rng As Range strPath = "C:\Vidu.xls" DoCmd.RunMacro "Macro2" tong = Forms!form1!lbltong.Caption Set xlApp = New Excel.Application Set wb = xlApp.Workbooks.Open(strPath) With wb.Worksheets(1) .Select FinalRow = .UsedRange.Rows.Count For x = 2 To FinalRow ThisValue = .Cells(x, 3).Value If ThisValue <> "" And .Cells(x, 4).Value <> "" Then .Cells(x, 2).Value = ThisValue Else With .Cells(x, 2) If .HorizontalAlignment = xlRight Then .Value = tong .Font.Color = vbBlack .HorizontalAlignment = xlLeft End If End With End If Next x .Range("C:C").EntireColumn.Delete 'Xoa cot C .Rows("1:16").Insert Shift:=xlDown ' Chèn vào 16 dòng tren dau trang .Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cot .Columns.EntireRow.AutoFit 'Tu dong chinh chieu cao cac dong End With xlApp.Visible = True 'Hien file excel lên Set wb = Nothing Set xlApp = Nothing Set Rng = Nothing Exit_Command2_Click: Exit Sub Err_Command2_Click: If Not xlApp Is Nothing Then xlApp.Quit Set xlApp = Nothing End If MsgBox Err.Description Resume Exit_Command2_Click End Sub
Demo

Khi nào mình luyện tới tầng thứ 9 hay "Như lai thần chưởng" thì cho nó một phát dẹp lép còn lại vài dòng thui
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

DoquangLam > 26-03-14, 09:27 AM

Rất hay. Coi như đã đạt được 98% yêu cầu của mình rồi (Code1 là chuẩn rồi đó), còn một vấn đề này nữa mong bạn bổ sung : Khi chuyển sang Excel có cột Ngày tháng (Cột F trên Excel) => Mình muốn cột này được định dạng kiểu ngày tháng năm là "d/m/yyyy"
Chỉ như vậy nữa là đạt 100% yêu cầu của mình rồi.
Cám ơn bạn.
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

DoquangLam > 26-03-14, 10:38 AM

Các bạn cho mình hỏi : Trong thư viện của access thiếu "Microsoft Excel 11.0 Object Library" thì phải làm sao ?
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

DoquangLam > 26-03-14, 10:51 AM

Đã hoàn thành và đạt yêu cầu 100% rồi.
Cám ơn tất cả các bạn, đặc biệt là bạn MatTroiNguQuen.
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

DoquangLam > 26-03-14, 11:21 AM

Đưa vào ứng dụng mới phát sinh thêm, nhờ bạn sửa lại một chút như sau : Khi chuyển sang Excel có cột MS thuế (Cột H trên Excel) => Mình muốn cột này được định dạng kiểu "Text"
Cám ơn bạn.

Bạn thêm code vào chỗ nào vui long tô chữ màu đỏ nhé, rối lắm không mò được.
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

MTNQ > 26-03-14, 12:55 PM

1-Định dạng cột F theo "d/m/yyyy":
wb.Worksheets(1).Columns(6).NumberFormat = "d/M/yyyy"

2-Định dạng cột H kiểu text:
wb.Worksheets(1).Columns(8).NumberFormat = "@"

Với wb là biến đối tượng Workbook đã khai báo như trong Demo của mình
Bạn thêm vào phía trên dòng code: End With

Mã:
With wb.Worksheets(1) ....... Next i .Rows("1:16").Insert Shift:=xlDown 'Chèn vào 16 dòng tren dau trang .Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cac cot .Columns.EntireRow.AutoFit 'Tu dong chinh chieu cao cac dong .Columns(6).NumberFormat = "d/M/yyyy" 'Dinh dang cot F kieu "d/M/yyyy" .Columns(8).NumberFormat = "@" 'Dinh dang cot H kieu Text End With
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

DoquangLam > 26-03-14, 02:53 PM

Cám ơn ! Chuẩn không cần chỉnh.
RE: Nhờ giúp đỡ code chuyển Reports sang Excel

trying58 > 01-08-20, 10:43 PM

(26-03-14, 12:55 PM)MTNQ Đã viết: 1-Định dạng cột F theo "d/m/yyyy":
wb.Worksheets(1).Columns(6).NumberFormat = "d/M/yyyy"

2-Định dạng cột H kiểu text:
wb.Worksheets(1).Columns(8).NumberFormat = "@"

Với wb là biến đối tượng Workbook đã khai báo như trong Demo của mình
Bạn thêm vào phía trên dòng code: End With

Mã:
With wb.Worksheets(1) ....... Next i .Rows("1:16").Insert Shift:=xlDown 'Chèn vào 16 dòng tren dau trang .Columns.EntireColumn.AutoFit 'Tu dong chinh chieu rong cac cot .Columns.EntireRow.AutoFit 'Tu dong chinh chieu cao cac dong .Columns(6).NumberFormat = "d/M/yyyy" 'Dinh dang cot F kieu "d/M/yyyy" .Columns(8).NumberFormat = "@" 'Dinh dang cot H kieu Text End With
bác ơi, mình có 2 report bên access cũng muốn xuất ra access nhưng áp dụng cách của bác ko đc, report của mình phân chia cột khác so với report của bác làm. bác có thể xem giúp mình với đc ko ạ
Bài trước Bài tiếp

Trang chủ click to expand contents

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

RE: Nhờ giúp đỡ code chuyển Reports sang Excel

loading