المساعدة فى كود ترحيل

[محمد ابومروان]

السلام عليكم أعضاء وخبراء المنتدى الكرام

تحية عطرة لكم جميعا

الرجاء المساعدة فى عمل زر خاص لترحيل الناجح وترحيل الدور الثانى من خلال كود VBA

ولكم جزيل الشكر

book9.xlsm

[احمد عبدالحليم]

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

تفضل اخى جرب الملف 

book9.xlsm

[حسونة حسين]

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

تفضل

Option Explicit

Sub Sucess_Fail()
    Dim WSData As Worksheet, WSSucess As Worksheet, WSFail As Worksheet, arr As Variant
    Dim i As Long, J As Long, P As Long, PP As Long, LR As Long, StateRng As Range, State1 As Long, State2 As Long
    
    Set WSData = ThisWorkbook.Worksheets("شيت")
    Set WSSucess = ThisWorkbook.Worksheets("ناجح")
    Set WSFail = ThisWorkbook.Worksheets("دور ثان")
    LR = Application.Max(3, WSData.Cells(Rows.Count, "B").End(xlUp).Row)
    arr = WSData.Range("A3:P" & LR).Value
    Set StateRng = WSData.Range("P2" & ":P" & LR)
    WSSucess.Range("A5:O" & Application.Max(5, WSSucess.Cells(Rows.Count, "B").End(xlUp).Row)).ClearContents
    WSFail.Range("A5:O" & Application.Max(5, WSFail.Cells(Rows.Count, "B").End(xlUp).Row)).ClearContents
    
    State1 = WorksheetFunction.CountIf(StateRng, "ناجح")
    State2 = WorksheetFunction.CountIf(StateRng, "دور ثان")
    P = 1
    PP = 1
    
    ReDim Sucess(1 To State1, 1 To UBound(arr, 2) - 1)
    ReDim Fail(1 To State2, 1 To UBound(arr, 2) - 1)
    
    For i = 1 To UBound(arr, 1)
        For J = 2 To UBound(arr, 2) - 1
            If arr(i, 16) = "ناجح" Then
                Sucess(P, 1) = P
                Sucess(P, J) = arr(i, J)
                If J = 15 Then P = P + 1
            ElseIf arr(i, 16) = "دور ثان" Then
                Fail(PP, 1) = PP
                Fail(PP, J) = arr(i, J)
                If J = 15 Then PP = PP + 1
            End If
        Next J
    Next i
    
    If P > 0 Then WSSucess.Range("A5").Resize(P - 1, UBound(Sucess, 2)).Value = Sucess
    If PP > 0 Then WSFail.Range("A5").Resize(PP - 1, UBound(Fail, 2)).Value = Fail

End Sub

 

Sucess_Fail.xlsm