Tạo code autofillter kết hợp in ấn (1 người xem)

khaiktt · 17/10/12

Xin các anh chị giúp em đoạn code để in lần lượt các mã trong cột "IN"
Trân trọng cảm ơn

Hai Lúa Miền Tây · 17/10/12

khaiktt đã viết:
Xin các anh chị giúp em đoạn code để in lần lượt các mã trong cột "IN"
Trân trọng cảm ơn

Dùng tạm ADO thử nhé.

Mã:

Sub InPhieu()
 Dim cnn As New ADODB.Connection
 Dim adoRS As New ADODB.Recordset
 Dim lsSQL As String, arr As Variant
 Dim r, c As Integer
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            lsSQL = "SELECT distinct F1 from [Sheet1$M7:M100] where f1 is not null "
            .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
            arr = .GetRows()
            .Close
            For c = LBound(arr, 2) To UBound(arr, 2)
                For r = LBound(arr, 1) To UBound(arr, 1)
                    Sheet2.Range("A6:M65000").ClearContents
                    lsSQL = "SELECT *  from " & _
                            "[Sheet1$A6:M65000]  " & _
                            "where [F13] like'" & arr(r, c) & "'"
                            
                    .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
                     Sheet2.Range("A6").CopyFromRecordset adoRS
                    .Close
                    Sheet2.PrintOut
                Next
            Next
        End With

        Set cnn = Nothing: Set adoRS = Nothing
End Sub

khaiktt · 17/10/12

Hai Lúa Miền Tây đã viết:

Dùng tạm ADO thử nhé.

Mã:

Sub InPhieu()
 Dim cnn As New ADODB.Connection
 Dim adoRS As New ADODB.Recordset
 Dim lsSQL As String, arr As Variant
 Dim r, c As Integer
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            lsSQL = "SELECT distinct F1 from [Sheet1$M7:M100] where f1 is not null "
            .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
            arr = .GetRows()
            .Close
            For c = LBound(arr, 2) To UBound(arr, 2)
                For r = LBound(arr, 1) To UBound(arr, 1)
                    Sheet2.Range("A6:M65000").ClearContents
                    lsSQL = "SELECT *  from " & _
                            "[Sheet1$A6:M65000]  " & _
                            "where [F13] like'" & arr(r, c) & "'"
                            
                    .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
                     Sheet2.Range("A6").CopyFromRecordset adoRS
                    .Close
                    Sheet2.PrintOut
                Next
            Next
        End With

        Set cnn = Nothing: Set adoRS = Nothing
End Sub

Bác giúp em chỉnh lại để em in được ở sheet 1 ạ
Trân trọng cảm ơn bác

Hai Lúa Miền Tây · 17/10/12

khaiktt đã viết:
Bác giúp em chỉnh lại để em in được ở sheet 1 ạ
Trân trọng cảm ơn bác

Thì đang in ở sheet1 rồi đó bạn, dữ liệu đưa qua sheet2 là dữ liệu từ shéet1 mà

khaiktt · 17/10/12

Bác cáo bác là thế này ạ
EM xây dựng bảng lương cho cả 12 tháng, vị vậy em muốn in trực tiếp tại sheet đó mà không chuyển sang sheet nào khác
Như vậy có được không bác
Cảm ơn bác đã quan tâm vấn đề của em

Hai Lúa Miền Tây · 17/10/12

khaiktt đã viết:
Bác cáo bác là thế này ạ
EM xây dựng bảng lương cho cả 12 tháng, vị vậy em muốn in trực tiếp tại sheet đó mà không chuyển sang sheet nào khác
Như vậy có được không bác
Cảm ơn bác đã quan tâm vấn đề của em

Vậy thì chỉnh lại như sau:

Mã:

Sub InPhieu()
 Dim cnn As New ADODB.Connection
 Dim adoRS As New ADODB.Recordset
 Dim lsSQL As String, arr As Variant
 Dim r, c As Integer
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            lsSQL = "SELECT distinct F1 from [Sheet1$M7:M100] where f1 is not null "
            .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
            arr = .GetRows()
            .Close
            For c = LBound(arr, 2) To UBound(arr, 2)
                For r = LBound(arr, 1) To UBound(arr, 1)
                    With Sheet1
                        .Range("M5:M307").AutoFilter Field:=1, Criteria1:=arr(r, c)
                        .PrintOut
                    End With
                Next
            Next
        End With
        Sheet1.ShowAllData
        Set cnn = Nothing: Set adoRS = Nothing
End Sub

khaiktt · 17/10/12

Bác cho em hoi nếu tên sheet bất kỳ thi phải điều chỉnh thế nào ạ

Hai Lúa Miền Tây · 18/10/12

khaiktt đã viết:
Bác cho em hoi nếu tên sheet bất kỳ thi phải điều chỉnh thế nào ạ

Thì bạn chỉnh tên sheet lại tương ứng là được.
Ví dụ bài trên là ở sheet1, bây giờ bạn tìm và thay thế lại là được.

Mã:

Sub InPhieu()
 Dim cnn As New ADODB.Connection
 Dim adoRS As New ADODB.Recordset
 Dim lsSQL As String, arr As Variant
 Dim r, c As Integer
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            lsSQL = "SELECT distinct F1 from [[B][COLOR=#ff0000]Sheet1[/COLOR][/B]$M7:M100] where f1 is not null "
            .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
            arr = .GetRows()
            .Close
            For c = LBound(arr, 2) To UBound(arr, 2)
                For r = LBound(arr, 1) To UBound(arr, 1)
                    With Sheets("[B][COLOR=#ff0000]Sheet1[/COLOR][/B]")
                        .Range("M5:M307").AutoFilter Field:=1, Criteria1:=arr(r, c)
                        .PrintOut
                    End With
                Next
            Next
        End With
        Sheets("[B][COLOR=#ff0000]Sheet1[/COLOR][/B]").ShowAllData
        Set cnn = Nothing: Set adoRS = Nothing
End Sub

khaiktt · 18/10/12

Cảm ơn bác MIỀN TÂY HAI LÚA nhiều

Hai Lúa Miền Tây · 19/10/12

khaiktt đã viết:
Bác xem giúp em cái này cái: Nó không chạy được ở đoạn ".Range("P5307").AutoFilter Field:=1, Criteria1:=arr(r, c)"

PHP:

Sub IN_THANG_01() Dim Sh As Worksheet, Ws As Worksheet Dim n, i As Integer Set Ws = Sheets("1") n = ThisWorkbook.Sheets.Count For i = 1 To n TenSh = Sheets.Item(i).Name Set Sh = Sheets(TenSh) If TenSh <> "1" Then With Ws.Range("P5").CurrentRegion .Range("P5:P307").AutoFilter Field:=1, Criteria1:=arr(r, c) .PrintOut .AutoFilter End With End If Next End Sub

Bác Hai Lúa Miền Tây xem giúp em cái đoạn code kia với, vì em chắpvá cho lên chưa được
Cảm ơn bác nhiều

Lỗi là đúng, điều kiện lọc của bạn ở đâu? Bạn muốn in toàn bộ sheet có trong file ngoại trừ sheet có tên là 1 với cùng cấu trúc và cùng điều kiện?
Nếu đúng thế tạm thời sửa code lại như sau:

Mã:

Sub IN_THANG_01()
On Error Resume Next
 Dim cnn As New ADODB.Connection, adoRS As New ADODB.Recordset
 Dim lsSQL As String, arr As Variant, Sh As Worksheet
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        With adoRS
            lsSQL = "SELECT distinct F1 from [Sheet1$M7:M100] where f1 is not null "
            .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
            arr = .GetRows()
            .Close
        End With
        Application.ScreenUpdating = False
               For Each Sh In ThisWorkbook.Sheets
                  If Sh.Name <> "1" Then
                     For c = LBound(arr, 2) To UBound(arr, 2)
                         For r = LBound(arr, 1) To UBound(arr, 1)
                             With Sh
                                 .Range("P5:P307").AutoFilter Field:=1, Criteria1:=arr(r, c)
                                 .PrintOut
                             End With
                         Next
                     Next
                     Sh.ShowAllData
                 End If
            Next
        Application.ScreenUpdating = True
     Set cnn = Nothing: Set adoRS = Nothing
End Sub

Bởi vì file bạn đưa lên khác với cái code ở trên, tôi đoán và làm đại. Đúng hay sai gì bạn tự chịu.

khaiktt · 19/10/12

Cảm ơn bác, quả thật là em copy vao file khác, file cua em nặng quá nên em copy một sheet để đưa lên diễn đàn chọ nhẹ ạ. Bảng dữ liệu của em là có 12 bảng lương của 12 tháng đặt tên lần lượt từ 1 đến 12. em muốn làm một phát in hết một tháng hết 12 tháng - mỗi một công trình in một bảng lương/1 tháng (Vì công ty xây dựng ạ)
Thật ngại quá vì đã làm bác mất công điều chỉnh. Nếu bác không phiền cho em xin địa chỉ mail để em gửi file gốc của em cho bác để tiện chỉnh sửa ạ
Một lần nữa cảm ơn và chúc bác mạnh khoẻ

Hai Lúa Miền Tây · 20/10/12

khaiktt đã viết:
Cảm ơn bác, quả thật là em copy vao file khác, file cua em nặng quá nên em copy một sheet để đưa lên diễn đàn chọ nhẹ ạ. Bảng dữ liệu của em là có 12 bảng lương của 12 tháng đặt tên lần lượt từ 1 đến 12. em muốn làm một phát in hết một tháng hết 12 tháng - mỗi một công trình in một bảng lương/1 tháng (Vì công ty xây dựng ạ)
Thật ngại quá vì đã làm bác mất công điều chỉnh. Nếu bác không phiền cho em xin địa chỉ mail để em gửi file gốc của em cho bác để tiện chỉnh sửa ạ
Một lần nữa cảm ơn và chúc bác mạnh khoẻ

BẠN SỬ DỤNG CODE TÔI SỬA LẠI NHƯ SAU:

Mã:

Sub InPhieu_HLMT()
On Error Resume Next
  Dim cnn As New ADODB.Connection
  Dim adoRS As New ADODB.Recordset
  Dim lsSQL As String, arr As Variant, Sh As Worksheet
        With cnn
            .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                           "Data Source=" & ThisWorkbook.FullName & _
                                           ";Extended Properties=""Excel 8.0;HDR=No;"";"
            .Open
        End With
        Application.ScreenUpdating = False
               For Each Sh In ThisWorkbook.Sheets
                  If UCase(Sh.CodeName) <> "SHEET17" And UCase(Sh.CodeName) <> "SHEET2" And UCase(Sh.CodeName) <> "SHEET3" & _
                                                    And UCase(Sh.CodeName) <> "SHEET4" And UCase(Sh.CodeName) <> "SHEET41" Then
                           With adoRS
                                lsSQL = "SELECT distinct F1 from [" & Sh.Name & "$P6:P307] where f1 is not null "
                                .Open lsSQL, cnn, adOpenStatic, adLockReadOnly
                                arr = .GetRows()
                              
                            End With
                            For c = LBound(arr, 2) To UBound(arr, 2)
                                For r = LBound(arr, 1) To UBound(arr, 1)
                                    With Sh
                                        If Len(arr(r, c)) > 1 Then
                                            .Range("P5:P307").AutoFilter Field:=1, Criteria1:=arr(r, c)
                                            .PrintOut
                                        End If
                                    End With
                                Next
                            Next
                            Sh.ShowAllData
                            adoRS.Close
                            Erase arr
                 End If
            Next
        Application.ScreenUpdating = True
     Set cnn = Nothing: Set adoRS = Nothing
End Sub

Lưu Ý: Cẩn thận khi test kẻo in ra hàng loạt, tốn giấy in.

khaiktt · 31/10/12

Cảm ơn bác HLMT đã giúp đỡ. Đoạn code này của bác đã giúp đỡ em rất nhiều
Kính chúc bác mạnh khoẻ, thành đạt

Tạo code autofillter kết hợp in ấn (1 người xem)

Người dùng đang xem chủ đề này

khaiktt

Thành viên chính thức

File đính kèm

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

File đính kèm

khaiktt

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

khaiktt

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

khaiktt

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

khaiktt

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

khaiktt

Thành viên chính thức

Hai Lúa Miền Tây

❆❆❆❆❆❆❆❆

File đính kèm

khaiktt

Thành viên chính thức

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian