Giúp mình in ấn từ trang đến trang trong excel! (1 người xem)

[thanhnam0119]

Chào các a chị! Nhờ các a chị giúp đỡ
em có file sheet "tổng hợp" và sheet "bieu_01bd" giờ em muốn in từ trang đến trang theo các hộ gia đình(mỗi hộ gia đình 1 trang). Xin các a chị giúp đỡ lệnh thể hiện hoàng loạt với tiêu chí mỗi hộ 1 trang in (theo mẫu ở sheet "bieu_01BD". E xin cảm ơn nhiều.
Option Explicit

Sub intheoho1()
Dim arr, arr1, dic As Object, lr As Long, i As Long, T, T1, a, s As String
Set dic = CreateObject("scripting.dictionary")
With Sheets("tong hop")
lr = .Range("B" & Rows.Count).End(xlUp).Row
If lr < 3 Then Exit Sub
arr = .Range("B3:L" & lr).Value
End With
For i = 1 To UBound(arr, 1)
If Not dic.exists(arr(i, 1)) Then
dic.Add arr(i, 1), i
Else
dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "#" & i
End If
Next i
For Each T In dic.keys
a = 0: ReDim arr1(1 To UBound(arr, 1), 1 To 10)
s = dic.Item(T)
For Each T1 In Split(s, "#")
a = a + 1
arr1(a, 1) = a
arr1(a, 2) = arr(T1, 3)
arr1(a, 3) = arr(T1, 2)
arr1(a, 4) = arr(T1, 4)
arr1(a, 5) = arr(T1, 5)
arr1(a, 6) = arr(T1, 8)
arr1(a, 7) = arr(T1, 9)
arr1(a, 8) = arr(T1, 7)
arr1(a, 9) = arr(T1, 1)
arr1(a, 10) = arr(T1, 11)
Next
With Sheets("Bieu 01_BD")
.Range("A14:j24").ClearContents
.Rows("14:24").EntireRow.Hidden = False
.Range("A14").Resize(a, 10) = arr1
.Rows(a + 14 & ":24").EntireRow.Hidden = True
.PrintPreview
End With
Next
End Sub

 

[snow25]

- nhưng a ơi ở mẫu 01_bd mất phần thể hiện tên của chủ hộ ạ
- ở phần danh sách có thể mất nhưng ở phần trên vẫn được giữ nguyên tên chủ hộ ạ

View attachment 213176

Code có mà.Với điều kiện bên sheets data của bạn có chữ chủ hộ thì nó mới nhận vào được.

 

[thanhnam0119]

Code có mà.Với điều kiện bên sheets data của bạn có chữ chủ hộ thì nó mới nhận vào được.

E thử rồi không chạy đc a à

 

[snow25]

E thử rồi không chạy đc a à

Bạn chạy code này nhé.

Sub intheoho1()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, T, T1, a, s As String, s1 As String, s2 As String, arr2, k As Long, bd As Long, kt As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("tong hop")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         arr = .Range("B3:L" & lr).Value
      If Len(.Range("P1")) = 0 Then Exit Sub Else bd = .Range("P1").Value - 1
      If Len(.Range("R1")) = 0 Then Exit Sub Else kt = .Range("R1").Value - 1
    End With
    For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) > 0 Then
        If Not dic.exists(arr(i, 1)) Then
           dic.Add arr(i, 1), i
        Else
           dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "#" & i
        End If
    End If
    Next i
    arr2 = dic.keys

      For k = bd To kt
        a = 0: ReDim arr1(1 To UBound(arr, 1), 1 To 10)
        s = dic.Item(arr2(k))
        s1 = Empty: s2 = Empty
        For Each T1 In Split(s, "#")
            If UCase(arr(T1, 9)) = UCase("Ch" & ChrW(7911) & " h" & ChrW(7897)) Then s1 = arr(T1, 3)
            s2 = arr(T1, 10)
          If Len(arr(T1, 11)) > 0 Then
            a = a + 1
            arr1(a, 1) = a
            arr1(a, 2) = arr(T1, 3)
            arr1(a, 3) = arr(T1, 2)
            arr1(a, 4) = arr(T1, 4)
            arr1(a, 5) = arr(T1, 5)
            arr1(a, 6) = arr(T1, 8)
            arr1(a, 7) = arr(T1, 9)
            arr1(a, 8) = arr(T1, 7)
            arr1(a, 9) = arr(T1, 1)
            arr1(a, 10) = arr(T1, 11)
         End If
       Next
       With Sheets("Bieu 01_BD")
            .Range("A14:j24").ClearContents
            .Range("C8").Value = s1
            .Range("D9").Value = s2
            .Range("E9").Value = "Xã (Th" & ChrW(7883) & " Tr" & ChrW(7845) & "n) : " & arr1(1, 6)
            .Rows("14:24").EntireRow.Hidden = False
            If a Then
            .Range("A14").Resize(a, 10) = arr1
            .Rows(a + 14 & ":24").EntireRow.Hidden = True
            .PrintPreview
            End If
       End With
   Next
End Sub

 

[thanhnam0119]

Bạn chạy code này nhé.

Sub intheoho1()
    Dim arr, arr1, dic As Object, lr As Long, i As Long, T, T1, a, s As String, s1 As String, s2 As String, arr2, k As Long, bd As Long, kt As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("tong hop")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 3 Then Exit Sub
         arr = .Range("B3:L" & lr).Value
      If Len(.Range("P1")) = 0 Then Exit Sub Else bd = .Range("P1").Value - 1
      If Len(.Range("R1")) = 0 Then Exit Sub Else kt = .Range("R1").Value - 1
    End With
    For i = 1 To UBound(arr, 1)
    If Len(arr(i, 1)) > 0 Then
        If Not dic.exists(arr(i, 1)) Then
           dic.Add arr(i, 1), i
        Else
           dic.Item(arr(i, 1)) = dic.Item(arr(i, 1)) & "#" & i
        End If
    End If
    Next i
    arr2 = dic.keys

      For k = bd To kt
        a = 0: ReDim arr1(1 To UBound(arr, 1), 1 To 10)
        s = dic.Item(arr2(k))
        s1 = Empty: s2 = Empty
        For Each T1 In Split(s, "#")
            If UCase(arr(T1, 9)) = UCase("Ch" & ChrW(7911) & " h" & ChrW(7897)) Then s1 = arr(T1, 3)
            s2 = arr(T1, 10)
          If Len(arr(T1, 11)) > 0 Then
            a = a + 1
            arr1(a, 1) = a
            arr1(a, 2) = arr(T1, 3)
            arr1(a, 3) = arr(T1, 2)
            arr1(a, 4) = arr(T1, 4)
            arr1(a, 5) = arr(T1, 5)
            arr1(a, 6) = arr(T1, 8)
            arr1(a, 7) = arr(T1, 9)
            arr1(a, 8) = arr(T1, 7)
            arr1(a, 9) = arr(T1, 1)
            arr1(a, 10) = arr(T1, 11)
         End If
       Next
       With Sheets("Bieu 01_BD")
            .Range("A14:j24").ClearContents
            .Range("C8").Value = s1
            .Range("D9").Value = s2
            .Range("E9").Value = "Xã (Th" & ChrW(7883) & " Tr" & ChrW(7845) & "n) : " & arr1(1, 6)
            .Rows("14:24").EntireRow.Hidden = False
            If a Then
            .Range("A14").Resize(a, 10) = arr1
            .Rows(a + 14 & ":24").EntireRow.Hidden = True
            .PrintPreview
            End If
       End With
   Next
End Sub

được rồi a à. e cảm ơn a nhiều nhé