أبو حنــــين

انا في انتظار الملف

جرب المرفق الآن 2.rar

السلام عليكم اعتذر عن تأخري في الرد لظروف العمل لكن الكود الذي ارسلته للاخ في مشاركتي رقم 2 يعمل بطريقة عادية عندي بحيث : ـ اولا قم بتلوين اي خلية ـ اخرج من الخلية ثم عد اليها تجد البيانات قد ثم ترحيلها للورقة الثانية ـ تستطيع عمل زر و نسخ الكود الى هذا الزر مع حذف السطر الاول من الكود

أخي سؤالك غير مفهوم ان كنت تقصد عمل الملف بالكود فقد قمت بذلك في المسشاركة رقم 5 هل إطلعت عليها ؟

جزاك الله خيرا أخي : / ياسر خليل و جعله الله في ميزان حسناتكم

السلام عليكم أخي جرب هذه المحاولة acc1.rar

السلام عليكم أخي كان من الأحسن رفع ملف للعمل عليه هذا تصور لما طلبته و لا ادي هل تقصد بهذه الطريقة ام هناك خطأ في فهمي للسؤال ترحيل صف كامل الى ورقة جديدة حسب اللون.rar

العفو أخي الحسين و الشكر موصول للأحباء : ـ عمرو رحيل ـ ياسر خليل

أخي ابراهيم ضع هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Target.Column = 1 And Target.Row > 1 Then If Target = "" Then Target.Offset(0, 2) = "" If Target <> "" Then Target.Offset(0, 2).Value = 1 End If If Target.Column = 2 And Target.Row > 1 Then If Target = "" Then Target.Offset(0, 1) = "" If Target <> "" Then Target.Offset(0, 1).Value = 2 End If End Sub

السلام عليكم جرب اخي المرفق ارقام الجلوس2.rar

السلام عليكم جرب المرفق 1.rar

جزاك الله خيرا أخي الحبيب أبو ردينة على مروركم

جرب أخي المرفق 1.rar

الأول كان بالدوال و هذا بالكود الايرادات بالكود.rar

جرب المرفق الايرادات تعديل.rar

بعد إذن الإخوة جرب المرفق Book1111.rar

هذا تعديل آخر حيث تم الاستغناء عن الفورم الاول و الثالث كما طلبت هناك ملاحظة في الصفحة الاولى يجب الاطلاع عليها ADSL REPORT4.rar

أشكرك أخي الحبيب أيو نصار أخي أحمد بالفعل كان هناك خطأ حيث كنت قد نسيت أحد الأعمدة المعنية بالنسخ و هذا هو التصحيح للكود السابق Sub AbouHanine() Dim LR As Integer, X As Integer, RR With ورقة2 .Range("A14:S200").ClearContents: .Range("A14:S200").Borders.LineStyle = xlNone End With LR = Cells(Rows.Count, "B").End(xlUp).Row Application.ScreenUpdating = False X = 14 For i = 14 To LR With ورقة1 Set RR = Application.Union(.Range("b" & i), .Range("c" & i), .Range("d" & i), .Range("q" & i) _ , Range("t" & i), Range("w" & i), Range("z" & i), .Range("ac" & i), .Range("af" & i) _ , .Range("ai" & i), .Range("al" & i), .Range("ao" & i), .Range("ap" & i), .Range("at" & i) _ , .Range("aw" & i), .Range("az" & i), .Range("bc" & i), .Range("bg" & i), .Range("bj" & i)) RR.Copy End With With ورقة2 .Range("a" & X).PasteSpecial xlPasteValues .Range("a" & X).Borders.LineStyle = xlContinuous: .Range("b" & X).Borders.LineStyle = xlContinuous .Range("d" & X).Borders.LineStyle = xlContinuous: .Range("c" & X).Borders.LineStyle = xlContinuous .Range("d" & X).Borders.LineStyle = xlContinuous: .Range("e" & X).Borders.LineStyle = xlContinuous .Range("f" & X).Borders.LineStyle = xlContinuous: .Range("g" & X).Borders.LineStyle = xlContinuous .Range("h" & X).Borders.LineStyle = xlContinuous: .Range("i" & X).Borders.LineStyle = xlContinuous .Range("j" & X).Borders.LineStyle = xlContinuous: .Range("k" & X).Borders.LineStyle = xlContinuous .Range("l" & X).Borders.LineStyle = xlContinuous: .Range("m" & X).Borders.LineStyle = xlContinuous .Range("n" & X).Borders.LineStyle = xlContinuous: .Range("o" & X).Borders.LineStyle = xlContinuous .Range("p" & X).Borders.LineStyle = xlContinuous: .Range("q" & X).Borders.LineStyle = xlContinuous .Range("r" & X).Borders.LineStyle = xlContinuous: .Range("s" & X).Borders.LineStyle = xlContinuous Application.CutCopyMode = False X = X + 1 End With Next i Application.ScreenUpdating = True MsgBox "ثم ترحيل البيانات بنجاح", vbInformation, "ترحيل" ورقة2.Select End Sub ترحيل2.rar

السلام عليكم جرب المرفق بعد التعديل ADSL REPORT 3.rar

السلام عليكم جرب أخي المرفق ترحيل.rar

أخي الحبيب الأستاذ ياسر خليل جزاك الله خيرا على هذه الملاحظة المهمة و طالما ان الكود اشتغل بدون هاذين السطرين فذلك أحسن و كذلك يستحسن وضع الكود في الحدث : Private Sub Workbook_BeforeClose Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim sh As Worksheet Set sh = Sheets("ورقة1") For t = 1 To 30 If sh.Cells(t, 1).Value > 0 Or sh.Cells(t, 1).Value <> "" Then sh.Cells(t, 1).Offset(0, 1) = Format(sh.Cells(t, 1).Offset(0, 1).Text, "@") End If Next End Sub

الخطأ كان في اختيار الأعمدة التي تحتوي على القسط و ليس التاريخ هذا الكود كان موجود في ملفك و هو خطأ : For Each Target In Range("R15:R602,V15:V602,X15:X602 . .. . . . . . . الى آخر قيمة و الصحيح هو : For Each Target In Range("U15:U602,W15:W602,Y15:Y602 . .. . . الى آخر قيمة بمعنى يجب اختيار الاعمدة التي تحتوي على قيمة القسط و ليس التاريخ و الله اعلم

هذه محاولة مني بعد إذن اخي الحبيب الأستاذ محمود فاتورة.rar

السلام عليكم جرب الملف و هناك استفسار وضعته في صورة مرفقة ADSL REPORT 2.rar

بالنسبة للموقع فلن تجد أحسن من هذا الموقع لما فيه من أساتذة كبار لا يبخلون بأي معلومه ابحث عن أي شيئ يخطر ببالك ستجده موجود في هذا المنتدي و إن لم تجده سيبادر الاخوه الكرام بالرد عليك شرط ان تتقيد بقوانين المنتدى و توضح طلبك و ترسل ملفا لذلك تبين فيه المطلوب اما بالنسبة للتعديل فسأحاول عمل ذلك لاحقا و اخبرك بالنتائج ان شاء الله