كود ترحيل بيانات مع وضع البيانات بطريقة صفحة صفحة

[aboesa]

كود ترحيل البيانات بطريقة صفحة صفحة كما في الملف.

Book1.xlsx

[سليم حاصبيا]

1-حيث ان البيانات كثيرة جداً فقد تم اختصار الملف الى حوالي 100 اسم للتحقق من عمل الماكرو (يمكن الان تعميم الماكرو على كل الملف)

2-هناك خلايا مدمجة في الملف مما يعيق عمل الماكرو (تم التعدبل على بنية الملف لازالة الخلايا المدمجة)

3-في المرة المقبلة حاول تجنب الخلايا المدمحة واختصار الملف الى أقل عدد ممكن من البيانات 

4- تم معالجة الامر في الملف المرفق

5- ارجو ان ينال الاعجاب

الكود

Option Explicit
Sub Give_Me_Data_Please()
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
  End With
Dim Data As Worksheet
Dim ws2 As Worksheet
Set Data = Sheets("data")
Set ws2 = Sheets("Archive")
  With ws2
    .Range("a38:j10000").ClearContents
    .Range("c10:j34").ClearContents
  End With
 
  Dim Capcity%, i%, k%, Max_ro%
  Dim ro%: ro = 39
  Dim first_row%: first_row = 10
  Dim lr_data%
  
  lr_data = Data.Application.Max(Data.Range("A:A"))
   Capcity = lr_data \ 25
    If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1
    
   For k = 1 To Capcity - 1
    ws2.Range("c5:j37").Copy ws2.Range("c" & ro)
    ro = ro + 33
   Next
  
  For i = 6 To lr_data + 25 Step 25
      ws2.Range("c" & first_row).Resize(25, 5).Value = _
      Data.Range("a" & i).Resize(25, 5).Value
      Max_ro = ws2.Range("c:c"). _
      Find(Application.Max(ws2.Range("c:c"))).Row
      
      first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9)
  Next
  
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
  End With
End Sub

الملف

 

ALL_In_one_sheet.xlsm

[وجيه شرف الدين]

تسلم ايدك استاذ سليم حل روعة جزاكم الله خير

[aboesa]

استاذ سليم بارك الله فيك وحفظك الله.تقبل الله منا ومنكم صالح الاعمال

[سليم حاصبيا]

1 ساعه مضت, aboesa said:

استاذ سليم بارك الله فيك وحفظك الله.تقبل الله منا ومنكم صالح الاعمال

المزيد في هذا الملف

حيث يتم ادراح مقاطع صفحات الطباعة (كل 25 اسم على لائحة منفردة)

الكود

Option Explicit
Sub Give_Me_Printing_Data_Please()
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
  End With
Dim Data As Worksheet
Dim ws2 As Worksheet
Set Data = Sheets("data")
Set ws2 = Sheets("Archive")
Dim m%: m = 1
Dim Arr()
Dim final_row
  With ws2
    .Range("a38:j10000").ClearContents
    .Range("c10:j34").ClearContents
  End With
 
  Dim Capcity%, i%, k%, Max_ro%
  Dim ro%: ro = 39
  Dim first_row%: first_row = 10
  Dim lr_data%
  
  lr_data = Data.Application.Max(Data.Range("A:A"))
   Capcity = lr_data \ 25
    If lr_data Mod Capcity > 0 Then Capcity = Capcity + 1
    
   For k = 1 To Capcity - 1
    ws2.Range("c5:j37").Copy ws2.Range("c" & ro)
    ro = ro + 33
   Next
  
  For i = 6 To lr_data + 25 Step 25
      ws2.Range("c" & first_row).Resize(25, 5).Value = _
      Data.Range("a" & i).Resize(25, 5).Value
      Max_ro = ws2.Range("c:c"). _
      Find(Application.Max(ws2.Range("c:c"))).Row
        first_row = IIf(i < 30, Max_ro + 10, Max_ro + 9)
        ReDim Preserve Arr(1 To m)
        Arr(m) = Max_ro + 3
        m = m + 1
  Next
   
  '===================================
  With Sheets("Archive")
    final_row = ws2.Cells(Rows.Count, "E").End(3).Row
    Arr(UBound(Arr)) = final_row + 2
    .PageSetup.PrintArea = .Range("c5:j" & final_row + 1).Address
    .ResetAllPageBreaks
    .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
    For k = 1 To UBound(Arr) - 1
     If k = UBound(Arr) - 1 Then
     .HPageBreaks.Add Before:=.Cells(Arr(k) + 3, 1)
     Else
     .HPageBreaks.Add Before:=.Cells(Arr(k) + 1, 1)
     End If
    Next
  End With
  '================================
  MsgBox "That is All" & Chr(10) & "You have  " & Capcity & " Pages To Print" _
   & Chr(10) & "Good Luck From Salim"
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
  End With
  Erase Arr
End Sub

الملف من حديد

 

 

Print_ALL_In_one_sheet.xlsm

[aboesa]

السلام عليكم .. استاذ سليم بارك الله في حضرتك 

اريد جلب اليانات بناء علي شرط رقم اللجن مع تقسيمها الي صفحات

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

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

كما في الملف المرفق

Print_ALL_In_one_sheet.xlsm

تم تعديل مايو 14, 2019 بواسطه aboesa