مساعدة فى معادلة او كود

[mk_mk_79]

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

طلبات.xls

[محمد هشام.]

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

Option Explicit
Sub CopyHeaders()
    Dim lastRow As Long, tmp As Long, Irow As Long
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    Application.ScreenUpdating = False
    lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row
    tmp = 7
    Irow = 2
    
    WS.Range("W8:Y" & WS.Rows.Count).ClearContents
    Do While tmp <= lastRow
        If Not IsEmpty(WS.Cells(tmp, "F")) And Not _
        IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then
            
            With WS.Cells(tmp + Irow, "W")
                .Value = WS.Cells(tmp, "F").Value
                .Offset(0, 1).Value = WS.Cells(tmp, "L").Value
                .Offset(0, 2).Value = WS.Cells(tmp, "R").Value
            End With

            Do While tmp <= lastRow And _
            (Not IsEmpty(WS.Cells(tmp, "F")) Or Not _
                IsEmpty(WS.Cells(tmp, "L")) Or Not IsEmpty(WS.Cells(tmp, "R")))
                tmp = tmp + 1
            Loop
        Else
            tmp = tmp + 1
        End If
    Loop
    Application.ScreenUpdating = True
End Sub

 

طلبات (1).xls

[mk_mk_79]

الاستاذ / محمد هشام 

اولا انا بشكر حضرتك على مساعدتك ليا . وربنا يجعله فى ميزان حسناتك . هو ده فعلا اللى انا عاوزة . بس كنت عايز تعديل بسيط فى الكود عشان يكمل فى باقى الصفوف . انا عايزه يبقى قدام كل صف مش الصف الاول بس من كل جدول . الملف المرفق يمكن يوضح كلامى 

وشاكر مقدما تعب حضرتك . ومهما قولت من كلام شكر مش ممكن يوفيك حقك 

طلبات.xls

[محمد هشام.]

تفضل أخي  @mk_mk_79

Sub CopyHeaders()
    Dim lastRow As Long, tmp As Long
    Dim n As Long, Irow As Long, ColArr As Variant
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")

    lastRow = WS.Cells(Rows.Count, "F").End(xlUp).Row
    Irow = 9
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    WS.Range("W" & Irow & ":Y" & WS.Rows.Count).ClearContents
    
    tmp = 7
    Do While tmp <= lastRow
        If Not IsEmpty(WS.Cells(tmp, "F")) And Not _
           IsEmpty(WS.Cells(tmp, "L")) And Not IsEmpty(WS.Cells(tmp, "R")) Then
           
            ColArr = Array(WS.Cells(tmp, "F").Value, _
            WS.Cells(tmp, "L").Value, WS.Cells(tmp, "R").Value)
            
            n = 0
            
            Do While tmp + n <= lastRow And _
                     (Not IsEmpty(WS.Cells(tmp + n, "F")) Or _
                      Not IsEmpty(WS.Cells(tmp + n, "L")) Or _
                      Not IsEmpty(WS.Cells(tmp + n, "R")))
                n = n + 1
            Loop
            
            With WS.Range(WS.Cells(Irow, "W"), WS.Cells(Irow + n - 1, "W"))
                .Value = ColArr(0)
                .Offset(0, 1).Value = ColArr(1)
                .Offset(0, 2).Value = ColArr(2)
            End With
            
            Irow = Irow + n + 3
            tmp = tmp + n
        Else
            tmp = tmp + 1
        End If
    Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

 

طلبات v2 .xls

[mk_mk_79]

استاذ / محمد هشام . الف مليون شكر على تعب حضرتك