طارق محمود

السلام عليكم إرسل ملفك ليسهل التعامل عليه لاتنسي ضغطه قبل الإرفاق الضغط باستخدام Winrar أو Winzip ثم ترفق الملف المضغوط

انظر ايضا الفيديو المرفق لكنه ليس اكسل 2003 لكن الفكرة واحد SORT1.rar

السلام عليكم ظلل المساحة كلها المطلوب ترتيبها ثم من قائمة Data إختر Sort وإجعل عمود الترتيب هو I ، الذي به النوع وجرب مرة الخيار Z>A أو A>Z

مرفق الملف وبه الكود الصحيح من وجهه نظري يمكنك تغيير السطرين الآخريين كما تحب Intersect.rar

السلام عليكم ضع الكود التالي في حدث الورقة 1 Private Sub Worksheet_Change(ByVal Target As Range) t = Target.Value If t = "" Then Exit Sub a = Target.Address If a = "$C$5" Then Sheets(2).[H7] = t If a = "$D$5" Then Sheets(2).[I7] = t If a = "$E$9" Then Sheets(2).[J8] = t If a = "$F$9" Then Sheets(2).[K9] = t End Sub ملحوظة أري أنه قد يكون اختلط الأمر عليك الصحيح J13 ، K13

السلام عليكم نعم أخي أسهل طريقة هي التنسيق الشرطي أنظر المرفق وبه قليل من الشرح تنسيق شرطي.rar

السلام عليكم اخي الحبيب / مجاهد حياك الله أنت عدلت فيه كثيرا كثيرا وليس قليلا ماشاء الله اراك أصبحت من الفوارس في هذا المضمار ولكن لابأس من معاونة الأصدقاء تم بحمد الله بالمرفق لم أفهم تحديدا المطلوب ولكن يمكن فتح الملف ووضع البيانات به ثم غلقه كبديل عن التعامل معه وهو مغلق تفضل المرفق به المطلوب أولا وحتي أجد الوقت للمطلوب الثاني أو تزيد الشرح شوية PACKING LIST2.rar

السلام عليكم أخي الحبيب يؤسفني والله الا أجيبك ولكن هذا العمل العظيم ليس من انتاجي قد أكون ساهمت فيه بقدر يسير علي العموم أنا سأحاول أولا أن أفهم تسلسل وتعاقب الأوامر وإن شاء الله إن لم يتدخل منتج العمل في يوم أو إثنين سأكون وفقت لعمل ماتريد

السلام عليكم هذا لأنني لم أضع بالحسبان تلك العلامات الخاصة التي بالملف "علامات السالب" ------ ------ ---- -- وأيضا عدلت ترتيب السطرين التاليين واستبدلت كلمة "end" بكلمة " ## " Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " الكود بعد التعديل أضفت خطوة لاستبدال أي علامة سالب بلاشيء Cells.Replace What:="-", Replacement:="" Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 Cells.Replace What:="-", Replacement:="" For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Or Left(Sheets(3).Cells(i, x), 1) <> "-" Then Sheets(3).Cells(i, j - 1).ClearContents Sheets(3).Cells(i, x + 1).Value = " ## " Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].Select End Sub

السلام عليكم أخي العزيز تفضل المرفق ينقل كما تريد للورقة3 وهذا هو الكود يمكنك تعديلها إلي ورقة2 باستبدال كل Sheets(3) إلي Sheets(2) Sub copy_2_end() LstC = [IV1].End(xlToLeft).Column LstR = [A65530].End(xlUp).Row Range("A1", [A1].Offset(LstR - 1, LstC - 1)).Select i = 1: j = 1: f_end = 0 For Each ce In Selection If f_end = 1 Then GoTo 10 5 Sheets(3).Cells(i, j).Value = ce.Value j = j + 1 If ce.Value = "end" Then For x = j - 2 To 1 Step -1 If Sheets(3).Cells(i, x) <> "" Then Sheets(3).Cells(i, x + 1).Value = "end" Sheets(3).Cells(i, j - 1).ClearContents Exit For End If Next x i = i + 1 j = 1 f_end = 1 End If GoTo 20 10 If ce.Value <> "" Then f_end = 0: GoTo 5 20 Next ce [A1].select End Sub أنظر للورقة 3 قبل ضغط زر الكود تفضل المرفق الانتقال الى خليه في حالة توفر شرط.rar

السلام عليكم أهلا أخي مراد حيا الله الجزائر وأهلها أين أنت يارجل صار لنا زمان ما سمعنا لك صوتا

السلام عليكم أخي العزيز عادة تضغط زر تسجيل الماكرو ثم تؤدي العمليات وسيقوم الاكسل بالتسجيل ويكتب أوتوماتيكيا ماتم في صفحة الفيجوال بيزيك ، تستطيع رؤيتها بالضغط علي ALT-F11 بالمرفق شرح بسيط للكود بالإكسل وكذلك فيديو صغير لكيفية تسجيل وقراءة الماكرو تفضل المرفق Record_Macro.rar

السلام عليكم أهلا ومرحبا بك أخي الكريم بين إخوانك إن شاء الله تفيد وتستفيد معنا أخي العزيز: إستخدم الدالة INDIRECT بدلا من =محمد!B3 تكتب =INDIRECT(B3&"!b3") حيث أن العمود الأول به الإسم / محمد طبعا لازم تكتب العمود الأول مطابق تماما لأسماء الشيتات واضفت لك تنسيق شرطي Conditional Format لكيلا يظهر خطأ إذا لم يكن هناك أسماء في العمود الأول تفضل المرفق مساعدة.rar

ممكن ولكن أطول بس نظرة للمعادلة التي وضعتها =IF(ISERROR(VLOOKUP(B2,$E$4:$F$7,2,0)),"",VLOOKUP(B2,$E$4:$F$7,2,0)) هي أصلا بسيطة كالتالي VLOOKUP(B2,$E$4:$F$7,2,0) فقط ولكني أضفت هذا الجزء ISERROR(VLOOKUP(B2,$E$4:$F$7,2,0)) فقط لكيلا يعطي خطأ إذا لم يجد الصفة في جدول البحث

السلام عليكم تفضل المرفق ارقام2.rar

أخي abumode75 الحديث دائما يفتح الأقدم

مرة أخري تأكد أن الكود مفعل (تخفيض مستوي أمان الماكرو) أنظر الصورة

أرسلت لك الملف علي الإميل ، ستجد به ماتريد إن شاء الله هو نفس الملف اتبع الخطوات التالية تأكد أن الكود مفعل (تخفيض مستوي أمان الماكرو) ضع أي بيانات نفترض أن يوم العمل إنتهي وأنك تريد ترحيل أرصدة اليوم لتبدأ يوم جديد ، فقط إضغط الزر الأزرق جرب وأخبرني

الأخ العزيز علي الروح القريب من القلب / ياسر الحافظ اللهم أعز سوريا وأهلها وسائر بلاد المسلمين أخي الكريم ، شاكرا جدا مرورك وكلماتك الرقيقة تقبل ودي واحترامي أخوكم طارق محمود (أبو زياد)

السلام عليكم أخي ديجابرو إستبدل الكود بالتالي سنقسم عملية النسخ واللصق ثلاث مقاطع لتلافي الخلايا التي بها معادلات Sub ToSchool() ' ' Macro1 Macro ' Lst_R = [B1000].End(xlUp).Row For r = 12 To Lst_R cls = Cells(r, 3) For w = 1 To Worksheets.Count a = Format(cls, "0") If Sheets(w).Name = a Then Range("B" & r & ":I" & r).Copy new_R = Sheets(a).[B1000].End(xlUp).Row + 1 Sheets(a).Range("B" & new_R).PasteSpecial Paste:=xlPasteValues Range("M" & r & ":N" & r).Copy Sheets(a).Range("M" & new_R).PasteSpecial Paste:=xlPasteValues Range("P" & r & ":R" & r).Copy Sheets(a).Range("P" & new_R).PasteSpecial Paste:=xlPasteValues Sheets(a).Range("A" & new_R).Value = Sheets(a).Range("A" & new_R - 1).Value + 1 Range("A" & r & ":I" & r).ClearContents Range("M" & r & ":N" & r).ClearContents Range("P" & r & ":R" & r).ClearContents Application.CutCopyMode = False GoTo 10 End If Next w ' No sheets named this Class MsgBox ("No Class =" & cls) Exit Sub 10 ' exit FOR w Next r End Sub Sub FromSchool() ' ' Macro1 Macro ' Lst_R = [B1000].End(xlUp).Row For r = 12 To Lst_R cls = Cells(r, 3) kid = Cells(r, 2) For w = 1 To Worksheets.Count a = Format(cls, "0") If Sheets(w).Name = a Then ' Range("B" & r & ":R" & r).Copy new_R = Sheets(a).[B1000].End(xlUp).Row For i = 11 To new_R kkid = Sheets(a).Cells(i, 2) If kkid = kid Then GoTo 15 Next i ' Not found the KID's name in this Class MsgBox ("No KID's named " & Chr(10) & kid & Chr(10) & "in Class " & a) Exit Sub 15 ' found the KID - exit FOR i (keep the Row number of Kid in i) Sheets(a).Range("B" & i + 1 & ":I" & new_R + 1).Copy Sheets(a).Range("B" & i).PasteSpecial Paste:=xlPasteValues Sheets(a).Range("M" & i + 1 & ":N" & new_R + 1).Copy Sheets(a).Range("M" & i).PasteSpecial Paste:=xlPasteValues Sheets(a).Range("P" & i + 1 & ":R" & new_R + 1).Copy Sheets(a).Range("P" & i).PasteSpecial Paste:=xlPasteValues Sheets(a).Range("A" & new_R).ClearContents Range("A" & r & ":I" & r).ClearContents Range("M" & r & ":N" & r).ClearContents Range("P" & r & ":R" & r).ClearContents GoTo 10 End If Next w ' No sheets named this Class MsgBox ("No Class =" & a) Exit Sub 10 ' exit FOR w Application.CutCopyMode = False Next r End Sub

أخي الفاضل إرسل الشيت بالمعادلات

السلام عليكم امسح البيانات كلها ظللها ثم Delete بس غير الكود للتالي Private Sub Worksheet_SelectionChange(ByVal Target As Range) [AB1] = [B4] End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$B$3" Then Exit Sub x = [AB1] If x = "" Then x = 0 [B4].FormulaR1C1 = "=R[-1]C+" & x End Sub كما هو قديما بس يزيد السطر If x = "" Then x = 0

السلام عليكم بالإضافة لحلول الإخوة الأفاضل تفضلي الملف المرفق للتذكير: يوجد بالإكسل دوال جاهزة لحساب الإهلاك DB للإهلاك الخطي البسيط DDB للإهلاك المائل باعتبار أن معدل إهلاك االمعدات أكثر في أول عمرها وينقص تدريجيا يمكنك القراءة عن ذلك تفضلي الملف المرفق محمد سعيد.rar

إعطيني اميلك أرسل لك الملف عليه

فقط للتذكير قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراء القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف