تعديل كود لفك مجموعة من الارقم من الى

[خير الايمان]

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

اساتذتي الكرام

مرفق كود المفروض ان يقوم بفك الارقام ( من    :     الى ) عند الضغط الزر   Run   فيقوم بذلك الا انه اذا كان هناك رقم لشخص واحد اي ان الرقم ( من ) هو الرقم ( الى ) لا يقوم الكود بنقله اي يتجهله كما هو موضح بالمثال هنا.

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

اعزكم الله

معدل.rar

[Foksh]

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

جرب هذا التعديل على حسب ما فهمت من الشرح  

 

Sub Test_Optimized()
    Dim ws As Worksheet, dataArr As Variant, outputArr() As Variant
    Dim i As Long, ii As Long, p As Long, startRow As Long, endRow As Long
    Dim chunkSize As Long, chunkStart As Long, chunkEnd As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set ws = ActiveSheet
    chunkSize = 5000
    ReDim outputArr(1 To chunkSize * 10, 1 To 14)
    
    With ws
        .Columns("Q:P").Clear
        .Columns("P").ColumnWidth = 12
        .Range("R1").Resize(, 14).Value = Array("الدفعة", "ج", "ت ح", "ت م", "ت ع", "ل ع", "ل ح", "ل م", "ل ع1", "ر ع1", "ل ح1", "ر ح1", "ل م", "ر م1")
        .Range("R1").Resize(, 14).Interior.Color = RGB(146, 205, 220)
        .Range("R1").Resize(, 14).HorizontalAlignment = xlCenter
        
        For chunkStart = 2 To 13000 Step chunkSize
            chunkEnd = chunkStart + chunkSize - 1
            If chunkEnd > 13000 Then chunkEnd = 13000
            dataArr = .Range("A" & chunkStart & ":N" & chunkEnd).Value
            p = 1
            
            For i = LBound(dataArr, 1) To UBound(dataArr, 1)
                If IsNumeric(dataArr(i, 2)) And IsNumeric(dataArr(i, 3)) Then
                    startRow = dataArr(i, 2)
                    endRow = dataArr(i, 3)
                    For ii = startRow To endRow
                        outputArr(p, 1) = dataArr(i, 1)
                        outputArr(p, 2) = ii
                        outputArr(p, 3) = dataArr(i, 4)
                        outputArr(p, 4) = dataArr(i, 5)
                        outputArr(p, 5) = dataArr(i, 6)
                        outputArr(p, 6) = dataArr(i, 7)
                        outputArr(p, 7) = dataArr(i, 8)
                        outputArr(p, 8) = dataArr(i, 9)
                        outputArr(p, 9) = dataArr(i, 10)
                        outputArr(p, 10) = dataArr(i, 11)
                        outputArr(p, 11) = dataArr(i, 12)
                        outputArr(p, 12) = dataArr(i, 13)
                        outputArr(p, 13) = dataArr(i, 14)
                        outputArr(p, 14) = dataArr(i, 14)
                        p = p + 1
                    Next ii
                End If
            Next i
            
            If p > 1 Then
                .Range("R" & chunkStart).Resize(p - 1, 14).Value = outputArr
                ReDim outputArr(1 To chunkSize * 10, 1 To 14)
            End If
        Next chunkStart
    End With
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

 

تم تعديل منذ 17 ساعات بواسطه Foksh
اضافة مرونة للكود

[خير الايمان]

استاذي الغملاق

Foksh

كعادتك بسرعة الاجابة الوافية

تجعل حرفي يعجز ان يوفي من شكر

بارك الله فيك وادم علمك

تقديري

[Foksh]

4 ساعات مضت, خير الايمان said:

استاذي الغملاق

Foksh

كعادتك بسرعة الاجابة الوافية

تجعل حرفي يعجز ان يوفي من شكر

بارك الله فيك وادم علمك

تقديري

بارك الله فيك ، وغفر لك ولوالديك والمسلمين 😇 

يسعدني أنك وجدت الحل مناسباً لك 🤗