• Tùy chọn
• Đăng nhập
• Đăng ký
• Xem như trên Máy tính
• Accelerated Mobile Pages Theme

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

• Trang chủ

  • Thủ Thuật Access
  • Access Nâng Cao
  • Tương tác Chương trình ngoài
  • [Help] Nhờ giúp đỡ code chuyển Reports sang Excel
• 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