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

[tuantu315]

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]

g em chạy code bên 2007 ko d

...........

 

[giaiphap]

Dạ đúng rồi đó ạ nhưng em chạy code bên 2007 ko dc

Trước lệnh

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

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

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

 

[tuantu315]

Trước lệnh

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

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

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

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

 

[BuiQuangThuan]

Trước lệnh

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

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

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]

Ra như hình này nè Anh
View attachment 268774

Thử thế này xem.

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]

Thử thế này xem.

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]

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]

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]

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]

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]

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]

Thử thế này xem.

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

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 ạ