تعديل علي كود

[2saad]

استاذي الفاضل / حسونة حسين

ارجو أن يتسع صدرك لي

انا عملت موضوع مستقل زي ما حضرتك طلبت

وعشمان في استفسار

هل ينفع في الملف المرفق 

ترحيل البياناتrazan.xlsm اللي في العمودين AA  و AB  في الشيت الأول الي العموددين  Y و Z  في الشيت الثاني

[حسونة حسين]

تفضل اخي

Option Explicit

Sub Test()
    Dim WSData As Worksheet, WSResult As Worksheet, Arr, Ar1, Ar2
    Dim I As Long, J As Long, P As Long
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set WSData = Worksheets("Sheet1")
    Set WSResult = Worksheets("Sheet2")
    Arr = WSData.Range("C10:AB" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value
    ReDim temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2) - 2)
    Ar1 = Array("سكر", "أرز", "بطاطس", "عنب")
    Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج")
    Dim x
    For I = 1 To UBound(Arr, 1)
        P = P + 1
        For J = 1 To UBound(Arr, 2) - 2
            If J < 13 Then
                temp(P, J) = Arr(I, J)
            ElseIf J > 22 Then
                temp(P, J) = Arr(I, J + 2)
            Else
                x = Application.Match(Arr(I, J + 1), Ar1, 0)
                If Not IsError(x) Then
                    temp(P, J) = Ar2(x - 1)
                    temp(P, J + 1) = Arr(I, J + 1)
                Else
                    temp(P, J) = "مخزن"
                    temp(P, J + 1) = Arr(I, J + 1)
                End If
                J = J + 1
            End If
        Next J
    Next I
    If P > 0 Then WSResult.Range("C10").Resize(P, UBound(temp, 2)).Value = temp
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[2saad]

بارك الله فيك وأكثر الله من أمثالك