تعديل علي كود ترحيل

[2saad]

إخواني أعضاء المنتدي الكرام بعد سلام عليكم ورحمة الله وبركاته

كود الترحيل يرحل من sheet1 الي  sheet2

محتاج اعدل في الكود بحيث يثبت الأعمدة الملونة باللون الأصفر  بحيث عند الترحيل لا ترحل اليها اي بيانات لأني سوف اضغ فيها معادلات ومش عايز تتمسح عند الترحيل

وشكرا

razan.xlsm

[حسونة حسين]

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

استبدل كودك بهذا الكود ولا تحمل هم المعادلات فتم الاستغناء عنها في الكود مباشره

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:X" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Ar1 = Array("سكر", "أرز", "بطاطس", "عنب")
    Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج")
    Dim x
    For I = 1 To UBound(Arr, 1)
        P = P + 1
        For J = 1 To UBound(Arr, 2)
            If J < 13 Then
                Temp(P, J) = Arr(I, J)
            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]

شكرا جزيلا وبارك الله فيك

 

[2saad]

لوسمحتم يا جماعة الكود المرفق ساعدني فيه الاستاذ / حسونة حسين( الله يبارك فيك ويجزيه أفضل الجزاء)

عايز ارحل العمودين الللي باللون الأصفر من شيت 1 الي شيت 2

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

razan.xlsm

[حسونة حسين]

رجاء كل طلب في موضوع مستقل

تفضل

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:Z" & WSData.Cells(Rows.Count, 3).End(xlUp).Row).Value
    ReDim temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
    Ar1 = Array("سكر", "أرز", "بطاطس", "عنب")
    Ar2 = Array("زيادة", "ناقص", "بكثرة", "محتاج")
    Dim x
    For I = 1 To UBound(Arr, 1)
        P = P + 1
        For J = 1 To UBound(Arr, 2)
            If J < 13 Or J > 22 Then
                temp(P, J) = Arr(I, J)
            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]

الله يبارك فيك 

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

اخوك لسه بيتعلم