2saad قام بنشر أبريل 15, 2023 مشاركة قام بنشر أبريل 15, 2023 إخواني أعضاء المنتدي الكرام بعد سلام عليكم ورحمة الله وبركاته كود الترحيل يرحل من sheet1 الي sheet2 محتاج اعدل في الكود بحيث يثبت الأعمدة الملونة باللون الأصفر بحيث عند الترحيل لا ترحل اليها اي بيانات لأني سوف اضغ فيها معادلات ومش عايز تتمسح عند الترحيل وشكرا razan.xlsm رابط هذا التعليق شارك More sharing options...
حسونة حسين قام بنشر أبريل 15, 2023 مشاركة قام بنشر أبريل 15, 2023 وعليكم السلام ورحمه الله وبركاته استبدل كودك بهذا الكود ولا تحمل هم المعادلات فتم الاستغناء عنها في الكود مباشره 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 2 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر أبريل 15, 2023 الكاتب مشاركة قام بنشر أبريل 15, 2023 شكرا جزيلا وبارك الله فيك رابط هذا التعليق شارك More sharing options...
2saad قام بنشر أبريل 16, 2023 الكاتب مشاركة قام بنشر أبريل 16, 2023 لوسمحتم يا جماعة الكود المرفق ساعدني فيه الاستاذ / حسونة حسين( الله يبارك فيك ويجزيه أفضل الجزاء) عايز ارحل العمودين الللي باللون الأصفر من شيت 1 الي شيت 2 ولكم جزيل الشكر ووافر الاحترام razan.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة حسونة حسين قام بنشر أبريل 16, 2023 أفضل إجابة مشاركة قام بنشر أبريل 16, 2023 رجاء كل طلب في موضوع مستقل تفضل 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 1 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر أبريل 16, 2023 الكاتب مشاركة قام بنشر أبريل 16, 2023 الله يبارك فيك ارجو أن يتسع صدرك اخوك لسه بيتعلم 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان