مطلوب اضافة عملية حسابية لكود الترحيل

[طالب مدرسة أوفيسنا]

السلام عليكم ،،، وجمعة مباركه على الجميع

 

بختصار // هذا الكود يقوم بالفلتره بواسطة عملية حسابيه

Sub Macro1()
Dim lr As Long
Application.ScreenUpdating = False
lr = Range("b" & Rows.Count).End(xlUp).Row
    Range("G18").FormulaR1C1 = "=MAX(R[1]C[-4]:R65536C3)"
    Range("H18").FormulaR1C1 = "=IF(RC[-4]>RC[-1],""تنفيذ"",)"
    Range("G18:H18").AutoFill Destination:=Range("G18:H" & lr), Type:=xlFillDefault
    Range("G18:H" & lr) = Range("G18:H" & lr).Value
    Application.ScreenUpdating = True
End Sub

وهذا الكود يقوم بترحيل ناتج العملية الحسابيه في حال توفر الشرط

Private Sub CommandButton1_Click()

Dim Cl As Range
If [H17] = "" Then Exit Sub
For Each Cl In Range("H18:H" & [H5000].End(xlUp).Row)
If Cl.Value = [H17] Then
Cl.Offset(0, -6).Resize(1, 3).Copy
Range("N" & [N5000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
MsgBox "تم الترحيل بنجاح ", vbOKOnly, "تنبيه"
End Sub

المطلوب اختصار العملية والاستغناء عن الفلتره ونقل العملية الحسابية لزر الترحيل بحيث يقوم بالحساب وترحيل مايوافق الشروط والاستغناء عن مالاتنطبق عليه الشروط

 

مع الشكر مرفق للتوضيح

نموذج1.rar

تم تعديل مايو 1, 2015 بواسطه x8.

[طالب مدرسة أوفيسنا]

لرفع

[الصـقر]

اخى الحبيب

خد كوبى من الكود اللى بحدث الورقه وانسخه فى الكود اللى بالمودويل هيكون بالشكل ده 

Sub Macro1()
Dim lr As Long
Application.ScreenUpdating = False
lr = Range("b" & Rows.Count).End(xlUp).Row
    Range("G18").FormulaR1C1 = "=MAX(R[1]C[-4]:R65536C3)"
    Range("H18").FormulaR1C1 = "=IF(RC[-4]>RC[-1],""تنفيذ"",)"
    Range("G18:H18").AutoFill Destination:=Range("G18:H" & lr), Type:=xlFillDefault
    Range("G18:H" & lr) = Range("G18:H" & lr).Value
    Dim Cl As Range
If [H17] = "" Then Exit Sub
For Each Cl In Range("H18:H" & [H5000].End(xlUp).Row)
If Cl.Value = [H17] Then
Cl.Offset(0, -6).Resize(1, 3).Copy
Range("N" & [N5000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next
MsgBox "تم الترحيل بنجاح", vbOKOnly, "تنبية"

    Application.ScreenUpdating = True
End Sub

وبعد كدا احذف الكود اللى بحدث الورقه ملوش لازمه جرب وعلمنى بالنتيجة

ملحوظه تم اضافه هذه الجزئية بالكود 

Application.CutCopyMode = False

وهى لايقاف عملية النسخ 

تقبل تحياتى

[طالب مدرسة أوفيسنا]

تسلم اخوي الصقر

يبدو اني لم اوصل الفكره بالشكل الصحيح

 

المطلوب ليس اختصار للكود فقط ايضا للعمليات مثل العمود G و H اريد الاستغناء عنها هي تقوم بالفرز في حال تطابق مع الشرط يكتب "تنفيذ" وفي حال عدم التطابق يعوض بصفر

 

مااريد اختصار لست في حاجه للعمود غير المطابق للشروط ، وارد الاختصار بحيث يبحث في حال كان مطابق يتم ترحيله وذا لم تنطابق يتجاهله وينتقل للتالي دون التعويض بصفر بحيث يكون الترحيل متتالي بدون اصفار او فراغات

 

مع الشكر