تعديل على الكود لتثبيت الصف الاول من كل صفحة

[sabah2023]

السلام عليكم

ممكن التعديل على الكود لتثبيت الصف الاول من كل صفحة

جزيتم خير

 

تعديل على الكود - اضافة عنوان اثناء التقسيم.xlsm

[sabah2023]

جزاك الله خير

والله افرحتني وسهلت عليه كثيرا

سهل الله عليك امورك 

تسلم

[محمد هشام.]

اليك اخي طريقة اسرع في حالة وجود عدد كبير من الصفوف المرحلة  الكود اطول لاكن اسرع  بكثير من الاول  😄يمكنك ترحيل 400 صف في 2 ثواني تقريبا

 

Sub Copy_Reports2()                                                                      
 ''''''''''''''''''    New additions to speed up code execution   '"""""""""""""""""""
Dim ws As Worksheet: Set ws = Sheets("البيانات")
Dim wsDest As Worksheet: Set wsDest = Worksheets("تقسيم")
Dim sMsg As String, rHeaders As Range, ligne As Range, t1 As Range, t2 As Range
Dim LastRow&, Titles&, Cpt&, lastCol&, col&, rngCell, r&, c As Range, Réf&, N&
 temps = Timer
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

limite = ws.Evaluate("SUM(0+(A4:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row & "<>""""))")
Set rHeaders = ws.Range("A1:P3")
Set ligne = wsDest.[A5]
wsDest.Cells.Clear
For x = 4 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If ws.Range("A" & x) <> "" Then: Rng = ws.Range("A4:P" & x)
  début = 1: TailleBloc = 10: décal = 0: Next
  Do While début <= UBound(Rng)
fin = début + TailleBloc - 1: If fin > UBound(Rng) Then fin = UBound(Rng)
b = Application.Index(Rng, Evaluate("Row(" & début & ":" & fin & ")"), Application.Transpose(Evaluate("Row(1:" & UBound(Rng, 2) & ")")))
    
    If ligne = 0 Then
    wsDest.Range("a" & Rows.Count).End(xlUp).Offset(3).Resize(UBound(b), UBound(b, 2)) = b
    
    Else
    
    Réf = wsDest.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    wsDest.Range("A" & Réf + 6).Resize(UBound(b), UBound(b, 2)) = b

    End If
     
décal = décal + UBound(Rng, 2) + 1: début = fin + 1
  Loop
wsDest.Activate
With wsDest.Cells
    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1
    .RowHeight = 40: .Columns(10).ColumnWidth = 23: .Columns(15).ColumnWidth = 16: .Font.Size = 16: .Font.Name = "Arial"
End With
    LastRow = wsDest.Range("A:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rngCell = wsDest.Range("A3 :P" & LastRow)
rngCell.Borders.LineStyle = xlNone
 For Each c In rngCell.Rows
   If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
Next

Cpt = 14
N = 1
For Titles = 1 To LastRow Step Cpt
If wsDest.Cells(Titles, "A").Offset(5, 0) <> "" Then
rHeaders.Copy
wsDest.Cells(Titles, 1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
Set t1 = wsDest.Cells(Titles, "B").Offset(13, 0)
Set t2 = wsDest.Cells(Titles, "C").Offset(13, 0)
          t1.Interior.Color = RGB(204, 255, 255): t1.Value = " رقم القائمة"
          t2.Value = N: t2.Interior.Color = RGB(204, 255, 255)
          Titles = Titles + 1
           N = N + 1
     End If
Next Titles
Application.CutCopyMode = False
With wsDest
For i = 3 To LastRow
On Error Resume Next
If wsDest.Cells(i, "M") Like "الكمية المحتسبة" And wsDest.Cells(i, "M").Offset(10, 0) <> "" Then
'تلوين الخلفية
wsDest.Cells(i, "j").Offset(11, 0).Resize(, 7).Interior.Color = vbYellow: wsDest.Cells(i, "J").Offset(11, 0).Value = "المجموع"
wsDest.Cells(i, "M").Interior.Color = vbYellow: wsDest.Cells(i, "O").Interior.Color = vbYellow
'الكمية المحتسبة
wsDest.Cells(i, "M").Offset(11, 0) = WorksheetFunction.Sum _
 (Range(Cells(i, "M").Offset(1, 0), Cells(i, "M").Offset(10, 0)))
'المبلغ الكلي
wsDest.Cells(i, "O").Offset(11, 0) = WorksheetFunction.Sum _
 (Range(Cells(i, "O").Offset(1, 0), Cells(i, "O").Offset(10, 0)))
' النقص
wsDest.Cells(i, "P").Offset(11, 0) = WorksheetFunction.Sum _
 (Range(Cells(i, "P").Offset(1, 0), Cells(i, "P").Offset(10, 0)))
  End If
Next i
[A3].Select
End With
On Error GoTo 0
sMsg = " تم ترحيل" & " " & limite & " مستند " & " " & "بنجاح"

MsgBox sMsg & vbCrLf & vbCrLf & " " & " " & "تم تنفيد الكود في:  " & Format(Timer - temps, "0.0000"), Exclamation, "اوفيسنا"

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

 

 

اضافة رقم القائمة 2.xlsm

تم تعديل نوفمبر 22, 2023 بواسطه محمد هشام.

[sabah2023]

جزيت خيرا

والله ابدعت

محترف

جزيت خيرا