الطباعة التسلسلي من 1 الى النهاية

ميلان · مارس 4, 2021

السلام عليكم اصدقائي لدي ملف بسيط من شيت بيانات واخر نموذج طباعة مكون من ثمان فواتير مثل ماهو موضح في الصورة

عند ادخال رقم واحد وضغط run يستحضر بيانات 8 مشتركين حسب الرقم الذي وضعه

المطلوب هل استطيع عند الضغط رقم واحد واعضغط run ان يقوم بطابعة كل الفواتير تلقائيا من 1 الى نهاية المستند تلقائيا بدون ان احضر كل ثمان ارقام على حده وشكرا للجميع الكود كتبه استاذي الكريم سليم حاصيبا وفقه الله وزاده علما

Option Explicit
Dim s As Worksheet
Dim T As Worksheet
Dim last As Long, Ro%
Dim s_rg As Range
Dim i%, K%, My_ro1%, My_ro2%, My_ro%
Dim m As Byte, n As Byte, xx As Byte
'++++++++++++++++++++++++++++++++
Sub Fatura()

Application.ScreenUpdating = False

 Set s = Sheets("Source")
 Set T = Sheets("Target")
 xx = 1
last = s.Cells(Rows.Count, 1).End(3).Row
If Val(T.Range("J1")) <= 0 Then
  i = 1
 Else
  i = Int(Abs(T.Range("J1")))
 End If
 
 T.Range("J1") = i
 T.Range("Rg_ALL").ClearContents
  For K = i + 3 To i + 10
  If K > last Then Exit For

 Select Case xx Mod 8
  Case 1: m = 2: n = 2
  Case 2: m = 2: n = 5
  Case 3: m = 11: n = 2
  Case 4: m = 11: n = 5
  Case 5: m = 20: n = 2
  Case 6: m = 20: n = 5
  Case 7: m = 29: n = 2
  Case 0: m = 29: n = 5
  End Select
   s.Cells(K, 1).Resize(, 7).Copy
   T.Cells(m, n).PasteSpecial _
   12, Transpose:=True
   xx = xx + 1

Next
Application.CutCopyMode = False
Print_Area
T.Cells(2, 1).Select
Application.ScreenUpdating = True
End Sub
'+++++++++++++++++++++++++++++++++++
Sub Print_Area()
Set T = Sheets("Target")
Ro = T.Cells(Rows.Count, 1).End(3).Row
 For i = 2 To Ro - 6 Step 9
    If T.Cells(i, 2) <> "" Then
       My_ro1 = i + 6
    End If
 Next
 
 For i = 2 To Ro - 6 Step 9
 
     If T.Cells(i, 5) <> "" Then
       My_ro2 = i + 6
    End If
 Next
 My_ro = Application.Max(My_ro1, My_ro2)
  
 T.PageSetup.PrintArea = T.Range("A1:E" & My_ro).Address
End Sub