نسخ نطاق محدد من الأعمدة إلى ورقة عمل جديدة

[ناصرالمصرى]

 

السلام عليكم ورحمة الله وبركاته

تحياتى للجميع وكل عام وحضراتكم بخير

لديّ هذا الكود الذي ينسخ نطاقًا محددا من الأعمدة مع جميع التنسيقات من ورقة العمل الرئيسية إلى ورقة العمل الجديدة التي سيتم نسخ نطاق البيانات إليها

مع إدراج خمسة صفوف فارغة بعد كل 25 صفًا لكنني أواجه صعوبة في إضافة بعض الاكواد  التي يجب تضمينها فى هذا الكود للحصول على النتائج المرجوة

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

لذلك أطلب من حضراتكم المساعدة فى إستكمال ما أريد تحقيقة فى هذا الموضوع حيث أحتاج الى 

**** إضافة صيغ الإجماليات بعد كل 25 صفًا في الصف الأول المدرج 

**** إضافة بعض السلاسل النصية كتوقيعات المسؤولين مثل ( أوفسينا - أوفسينا 1 - أوفسينا 2 - أوفسينا 3 - أوفسينا 4 ) في أسفل الجداول مباشرة  في الصف الثاني المدرج .

**** إضافة صيغ الإجماليات السابقة ( جملة ماقبله ) في الصف الخامس المدرج .

أعلم جيدا أن كتابة كود يحتاج الى تركيز غالى وينبغى رفع موضوع لكل نقطة من النقاط الثلاثة المطلوب تحقيقها

ولكن لكى تكمتل فكرة الموضوع أردت أن يكونوا فى موضوع واحد ... آمل أن أحصل على مساعدة حضراتكم فى هذا الموضوع

لقد أرفقت عينة من المصنف تبين بوضوح ما أحاول تحقيقه في ورقة الإخراج المطلوب بعد إضافة الأكواد المتوقعة من حضراتكم

شاكر فضل حضراتكم وجزاكم الله خيرا.

Example.xlsb.xlsm

تم تعديل أغسطس 18, 2019 بواسطه ناصرالمصرى

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

جرب مبدئياً هذا الماكرو

يمكن تحسينه فيما بعد

ضع في  My_arr   داخل  الكود ما تريد من تواقيع

Option Explicit

Sub Salim_Code()
    Const lngFirstRow = 7
    Const lngRowsPerPage = 25
    Dim my_ro#
    Dim wshSource As Worksheet, wshTarget As Worksheet
    Dim rgSource As Range, rgTarget As Range
    Dim lngLastRow#, Final_row#, lngRow#
    Dim lngNumRows#, lngNumPages#, i#
    Dim My_arr(), k%: k = 8 + lngRowsPerPage
    My_arr = Array("Ok1", "", "Ok2", "", "Ok3", "", "Ok4", "", _
    "Ok5", "", "Ok6")
    Set wshSource = Worksheets("الرئيسية")
    With wshSource
        lngLastRow = .Range("A:GC").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set rgSource = .Range("FI" & lngFirstRow & ":GC" & lngLastRow)
    End With
   
With Worksheets("الجديدة")
   .Cells.ClearContents
    Set rgTarget = .Range("A" & lngFirstRow)
    rgSource.Copy
    rgTarget.PasteSpecial xlPasteAll
    Final_row = .Cells(Rows.Count, 1).End(3).Row
        With .PageSetup
        .PrintArea = Range("a7:u" & Final_row).Address
        .Orientation = xlLandscape
        .PrintTitleRows = "$1:$7"
        End With
End With
   
    Application.CutCopyMode = False
    lngNumRows = lngLastRow - lngFirstRow
    lngNumPages = lngNumRows \ lngRowsPerPage
    If lngNumRows Mod lngRowsPerPage > 0 Then
        lngNumPages = lngNumPages + 1
    End If
    With Worksheets("الجديدة")
   .ResetAllPageBreaks

 For i = lngRowsPerPage + 8 To Final_row Step lngRowsPerPage

.Range("A" & i).Resize(5).EntireRow.Insert
  .HPageBreaks.Add Before:=Range("A" & i)
  .Range("b" & i + 1) = "SUM"
  If i = lngRowsPerPage + 8 Then
  .Range("d" & i + 1).Resize(, 18).Formula = _
  "=SUM(D" & 8 & ":D" & 32 & ")"
  Else
  .Range("d" & i + 1).Resize(, 18).Formula = _
  "=SUM(D" & k - 20 & ":D" & k - 1 & ")"
  End If
  .Range("a" & i + 2).Resize(, UBound(My_arr)) = My_arr
  k = k + 25
  Next
    Final_row = .Cells(Rows.Count, 1).End(3).Row
   .Range("A" & Final_row + 1).Resize(5).EntireRow.Insert
   .PageSetup.PrintArea = Range("a7:u" & Final_row + 5).Address
   .Range("b" & Final_row + 1) = "SUM"
  .Range("a" & Final_row + 2).Resize(, UBound(My_arr)) = My_arr

   For i = Final_row To 2 Step -1
    If .Range("B" & i) = vbNullString Then
     my_ro = .Range("B" & i).Row + 1
      Exit For
      End If
    Next
.Range("d" & Final_row + 1).Resize(, 18).Formula = _
"=SUM(D" & my_ro & ":D" & Final_row & ")"
On Error Resume Next
.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
  .Range("a1").Select
   End With
End Sub

الملف مرفق

 

 

Example_ٍsalim.xlsm

[ناصرالمصرى]

السلام عليكم ورحمة الله وبركاته

بداية أخى وأستاذى الفاضل سليم أعتذر للتأخير فى الرد

مبدئيا قد يكون هناك تحسينات لعمل الكود

لذلك أرجو إعطائى بعض الوقت للعمل على الملف الأصلى وسوف أخبرك لاحقا عن أى ملاحظات

شاكر فضل حضرتك وجزاكم الله خيرا

 

[ناصرالمصرى]

السلام عليكم ورحمة الله وبركاته

لقد أمضيت وقتًا طويل في محاولة معرفة ذلك بمفردي واستكشاف خيارات مختلفة ولكن لسوء الحظ.

لذلك يُرجى مشاهدة ورقة الاخراج المطلوب مرة أخرى **** شاكر فضل حضراتكم وجزاكم الله خيرا

 

 

Example+111.xlsb.xlsm

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

تم التعديل على الماكرو

Option Explicit
Sub Salim_Code_new()
Application.ScreenUpdating = False
    Const lngFirstRow = 7
    Const lngRowsPerPage = 25
    Dim my_ro#, x%
    Dim wshSource As Worksheet, wshTarget As Worksheet
    Dim rgSource As Range, rgTarget As Range
    Dim lngLastRow#, Final_row#, lngRow#
    Dim lngNumRows#, lngNumPages#, i#
    Dim My_arr(), k%: k = 8 + lngRowsPerPage
    My_arr = Array("Ok1", "", "Ok2", "", "Ok3", "", "Ok4", "", _
    "Ok5", "", "Ok6")
    Set wshSource = Worksheets("الرئيسية")
    With wshSource
        lngLastRow = .Range("A:GC").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set rgSource = .Range("FI" & lngFirstRow & ":GC" & lngLastRow)
    End With
   
With Worksheets("الجديدة")
   .Cells.ClearContents
    Set rgTarget = .Range("A" & lngFirstRow)
    rgSource.Copy
    rgTarget.PasteSpecial xlPasteAll
    Final_row = .Cells(Rows.Count, 1).End(3).Row
        With .PageSetup
        .PrintArea = Range("a7:u" & Final_row).Address
        .Orientation = xlLandscape
        .PrintTitleRows = "$1:$7"
        End With
End With
   
    Application.CutCopyMode = False
    lngNumRows = lngLastRow - lngFirstRow
    lngNumPages = lngNumRows \ lngRowsPerPage
    If lngNumRows Mod lngRowsPerPage > 0 Then
        lngNumPages = lngNumPages + 1
    End If
    With Worksheets("الجديدة")
   .ResetAllPageBreaks

 For i = lngRowsPerPage + 8 To Final_row Step lngRowsPerPage

.Range("A" & i).Resize(5).EntireRow.Insert
  .HPageBreaks.Add Before:=Range("A" & i + 5)
  .Range("b" & i + 1) = "SUM"
  If i = lngRowsPerPage + 8 Then
  .Range("d" & i + 1).Resize(, 18).Formula = _
  "=SUM(D" & 8 & ":D" & 32 & ")"
  Else
  .Range("d" & i + 1).Resize(, 18).Formula = _
  "=SUM(D" & k - 20 & ":D" & k - 1 & ")"
  End If
  .Range("a" & i + 2).Resize(, UBound(My_arr)) = My_arr
  k = k + 25
  Next
    Final_row = .Cells(Rows.Count, 1).End(3).Row
   .Range("A" & Final_row + 1).Resize(5).EntireRow.Insert
   .PageSetup.PrintArea = Range("a7:u" & Final_row + 5).Address
   .Range("b" & Final_row + 2) = "SUM"
  .Range("a" & Final_row + 3).Resize(, UBound(My_arr)) = My_arr

   For i = Final_row To 2 Step -1
    If .Range("B" & i) = vbNullString Then
     my_ro = .Range("B" & i).Row + 1
      Exit For
      End If
    Next
.Range("d" & Final_row + 2).Resize(, 18).Formula = _
"=SUM(D" & my_ro & ":D" & Final_row & ")"
On Error Resume Next
x = .VPageBreaks.Count
If x <> 0 Then
.VPageBreaks.DragOff Direction:=xlToRight, RegionIndex:=1
End If
.UsedRange.Value = .UsedRange.Value
.Range("a7").Select
    End With
    Application.ScreenUpdating = True
End Sub

الملف من جديد

 

Example+SALIM.xlsm