Chọn Vùng In Có Điều Kiện

tuantu315 · 4/11/21

Chào Anh/Chị Diễn Đàn mong anh chị giúp em thu gọn code hoặc có code nào giải quyết vấn đề chọ vùng in khi thỏa mãn diều kiện cho trước.
Em có viết 1 đoạn code như bên dưới để chọn vùng để in nhưng vấn đề gặp phải là code em quá dài và ko hiệu quả. Em có gởi file lên mong Anh/Chị giúp đỡ . Thanks Ạ

if sheet5.range("A1") >< "" then
Worksheets("Sheet5").PageSetup.PrintArea = "A1:A3"
end if
if sheet5.range("c1") >< "" then
Worksheets("Sheet5").PageSetup.PrintArea = "A1:C3"
end if
........................>

BuiQuangThuan · 4/11/21

tuantu315 đã viết:
g em chạy code bên 2007 ko d

...........

giaiphap · 4/11/21

tuantu315 đã viết:
Dạ đúng rồi đó ạ nhưng em chạy code bên 2007 ko dc

Trước lệnh

Mã:

.PageSetup.PrintArea = Right(T, Len(T) - 1)

thử thêm cái này xem nó ra cái quái gì?

Mã:

Msgbox Right(T, Len(T) - 1)

tuantu315 · 4/11/21

giaiphap đã viết:
Trước lệnh

Mã:

.PageSetup.PrintArea = Right(T, Len(T) - 1)

thử thêm cái này xem nó ra cái quái gì?

Mã:

Msgbox Right(T, Len(T) - 1)

Ra như hình này nè Anh

BuiQuangThuan · 4/11/21

giaiphap đã viết:
Trước lệnh

Mã:

.PageSetup.PrintArea = Right(T, Len(T) - 1)

thử thêm cái này xem nó ra cái quái gì?

Mã:

Msgbox Right(T, Len(T) - 1)

Trong mấy cái ô xét điều kiện. Nhìn là rỗng. Nhưng không phải là rỗng

giaiphap · 4/11/21

tuantu315 đã viết:
Ra như hình này nè Anh
View attachment 268774

Thử thế này xem.

Mã:

Sub ABC()
    Dim Rng As Range, Vung As Range
    With Sheets("in tem")
        For Each Rng In Range("A1:M1,A5:M5,A9:M9,A13:M13")
            If Rng.Value <> "" Then
                If Vung Is Nothing Then
                    Set Vung = Rng.Resize(3, 2)
                Else
                    Set Vung = Union(Vung, Rng.Resize(3, 2))
                End If
            End If
        Next
        .PageSetup.PrintArea = Vung.Address
    End With
End Sub

BuiQuangThuan · 4/11/21

giaiphap đã viết:

Thử thế này xem.

Mã:

Sub ABC()
    Dim Rng As Range, Vung As Range
    With Sheets("in tem")
        For Each Rng In Range("A1:M1,A5:M5,A9:M9,A13:M13")
            If Rng.Value <> "" Then
                If Vung Is Nothing Then
                    Set Vung = Rng.Resize(3, 2)
                Else
                    Set Vung = Union(Vung, Rng.Resize(3, 2))
                End If
            End If
        Next
        .PageSetup.PrintArea = Vung.Address
    End With
End Sub

Đúng thế này mới chuẩn này. Lần trước nhìn thấy bác SA làm thế này mà em không nhớ nổi.

Mr.hieudoanxd · 4/11/21

Mình hay làm như thế này, tạo hàm phụ AdressCell để xác định vị trí in

Function AdressCell(Rng As Range) As String
On Error Resume Next
    Dim kq1 As String, kq2 As String, m As Long
    m = Rng.count
    kq1 = NtC(Rng.Cells(1).Column) & Rng.Cells(1).Row
    kq2 = NtC(Rng.Cells(m).Column) & Rng.Cells(m).Row
    If m = 1 Then
        AdressCell = kq1
    Else
        AdressCell = kq1 & ":" & kq2
    End If
End Function

Private Function NtC(number As Long) As String
On Error Resume Next
    Dim aSplit As Variant
    aSplit = VBA.Split(Cells(1, number).Address, "$")
    NtC = aSplit(1)
End Function

sau đó nối các vùng trên lại để ra vùng in tổng bằng hàm phụ JoinText

Function JoinText(Area As Range,  Delimiter As String, Optional ByVal Only As Long = 1, Optional ByVal ignore_empty As Long = 1)
    On Error Resume Next
    Dim Rng As Range, kq As String
    For Each Rng In Area
        If ignore_empty = 1 Then
            If Rng = VBA.vbNullString Then
                kq = kq
            Else
                If Only <> 1 Then
                    If VBA.InStr(kq, Rng & Delimiter) = 0 Then ', vbBinaryCompare
                        kq = kq & Rng & Delimiter
                    Else: kq = kq
                    End If
                Else: kq = kq & Rng & Delimiter
                End If
            End If
        Else: kq = kq & Rng & Delimiter
        End If
    Next Rng

    If kq = VBA.vbNullString Then
        kq = VBA.vbNullString
    Else
        kq = VBA.Left(kq, VBA.Len(kq) - VBA.Len(Delimiter))
    End If
   
    JoinText = kq
End Function

sau khi xác định được vùng in rồi thì lúc này vùng setup vùng in:

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = Range(".........").value

Maika8008 · 5/11/21

Mr.hieudoanxd đã viết:
Mình hay làm như thế này, tạo hàm phụ AdressCell để xác định vị trí in
Function AdressCell(Rng As Range) As String On Error Resume Next Dim kq1 As String, kq2 As String, m As Long m = Rng.count kq1 = NtC(Rng.Cells(1).Column) & Rng.Cells(1).Row kq2 = NtC(Rng.Cells(m).Column) & Rng.Cells(m).Row If m = 1 Then AdressCell = kq1 Else AdressCell = kq1 & ":" & kq2 End If End Function Private Function NtC(number As Long) As String On Error Resume Next Dim aSplit As Variant aSplit = VBA.Split(Cells(1, number).Address, "$") NtC = aSplit(1) End Function

sau đó nối các vùng trên lại để ra vùng in tổng bằng hàm phụ JoinText
Function JoinText(Area As Range, Delimiter As String, Optional ByVal Only As Long = 1, Optional ByVal ignore_empty As Long = 1) On Error Resume Next Dim Rng As Range, kq As String For Each Rng In Area If ignore_empty = 1 Then If Rng = VBA.vbNullString Then kq = kq Else If Only <> 1 Then If VBA.InStr(kq, Rng & Delimiter) = 0 Then ', vbBinaryCompare kq = kq & Rng & Delimiter Else: kq = kq End If Else: kq = kq & Rng & Delimiter End If End If Else: kq = kq & Rng & Delimiter End If Next Rng If kq = VBA.vbNullString Then kq = VBA.vbNullString Else kq = VBA.Left(kq, VBA.Len(kq) - VBA.Len(Delimiter)) End If JoinText = kq End Function

sau khi xác định được vùng in rồi thì lúc này vùng setup vùng in:
ActiveSheet.PageSetup.PrintArea = "" ActiveSheet.PageSetup.PrintArea = Range(".........").value

Tại sao bạn phải thêm VBA. trước các hàm, thậm chí trước hằng vbNullString luôn?

Mr.hieudoanxd · 5/11/21

Maika8008 đã viết:
Tại sao bạn phải thêm VBA. trước các hàm, thậm chí trước hằng vbNullString luôn?

Em đọc ở trên diễn đàn có người viết là thêm vba. tốc độ sẽ nhanh hơn mà ko tìm được bài viết đó dẫn cho a xem

Maika8008 · 5/11/21

Mr.hieudoanxd đã viết:
Em đọc ở trên diễn đàn có người viết là thêm vba. tốc độ sẽ nhanh hơn mà ko tìm được bài viết đó dẫn cho a xem

Tôi thấy không có sách nào (mà tôi đã đọc) viết thế và các chuyên gia trên GPE không ai dùng code kiểu như thế nên chắc là không có chuyện cải thiện tốc độ đâu. Nó làm cho việc viết code chậm hơn thì có.

giaiphap · 5/11/21

Maika8008 đã viết:
Tại sao bạn phải thêm VBA. trước các hàm, thậm chí trước hằng vbNullString luôn?

Tôi thấy có cái lợi là khi gõ VBA xong "." một cái là nó liệt kê các hàm mà không cần phải nhớ tên chi tiết của hàm.

tuantu315 · 5/11/21

giaiphap đã viết:

Thử thế này xem.

Mã:

Sub ABC()
    Dim Rng As Range, Vung As Range
    With Sheets("in tem")
        For Each Rng In Range("A1:M1,A5:M5,A9:M9,A13:M13")
            If Rng.Value <> "" Then
                If Vung Is Nothing Then
                    Set Vung = Rng.Resize(3, 2)
                Else
                    Set Vung = Union(Vung, Rng.Resize(3, 2))
                End If
            End If
        Next
        .PageSetup.PrintArea = Vung.Address
    End With
End Sub

Thanks Anh nhiều !! Em làm được rồi ạ

Bài đã được tự động gộp: 5/11/21

Mr.hieudoanxd đã viết:
Mình hay làm như thế này, tạo hàm phụ AdressCell để xác định vị trí in
Function AdressCell(Rng As Range) As String On Error Resume Next Dim kq1 As String, kq2 As String, m As Long m = Rng.count kq1 = NtC(Rng.Cells(1).Column) & Rng.Cells(1).Row kq2 = NtC(Rng.Cells(m).Column) & Rng.Cells(m).Row If m = 1 Then AdressCell = kq1 Else AdressCell = kq1 & ":" & kq2 End If End Function Private Function NtC(number As Long) As String On Error Resume Next Dim aSplit As Variant aSplit = VBA.Split(Cells(1, number).Address, "$") NtC = aSplit(1) End Function

sau đó nối các vùng trên lại để ra vùng in tổng bằng hàm phụ JoinText
Function JoinText(Area As Range, Delimiter As String, Optional ByVal Only As Long = 1, Optional ByVal ignore_empty As Long = 1) On Error Resume Next Dim Rng As Range, kq As String For Each Rng In Area If ignore_empty = 1 Then If Rng = VBA.vbNullString Then kq = kq Else If Only <> 1 Then If VBA.InStr(kq, Rng & Delimiter) = 0 Then ', vbBinaryCompare kq = kq & Rng & Delimiter Else: kq = kq End If Else: kq = kq & Rng & Delimiter End If End If Else: kq = kq & Rng & Delimiter End If Next Rng If kq = VBA.vbNullString Then kq = VBA.vbNullString Else kq = VBA.Left(kq, VBA.Len(kq) - VBA.Len(Delimiter)) End If JoinText = kq End Function

sau khi xác định được vùng in rồi thì lúc này vùng setup vùng in:
ActiveSheet.PageSetup.PrintArea = "" ActiveSheet.PageSetup.PrintArea = Range(".........").value

Hơi dài dòng nhưng cũng có thêm 1 cách khác nữa... Thanks nhiu ạ

Chọn Vùng In Có Điều Kiện

tuantu315

Thành viên hoạt động

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

giaiphap

==(^o^)==

tuantu315

Thành viên hoạt động

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

giaiphap

==(^o^)==

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

Mr.hieudoanxd

Thành viên thường trực

Maika8008

Thành viên gạo cội

Mr.hieudoanxd

Thành viên thường trực

Maika8008

Thành viên gạo cội

giaiphap

==(^o^)==

tuantu315

Thành viên hoạt động

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

Facebook

Group

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