احمدزمان

‏الاربعاء‏، 26‏/3‏/1442هـ الموافق ‏11‏/11‏/2020م السلام عليكم و رحمة الله وبركاته اخي الكريم كلامك صحيح يوجد تكرار للترحيل و انت لم تحدد سابقا في طلبك عدم التكرار للبيانات ===== لذلك ان عدم تكرار البيانات في الترحيل هنا له 3 طرق 1 يتم مسح البيانات التي تم ترحيلها من داخل الكود بحيث ان كل صف يتم ترحيله يتم مسح هذا الصف 2 يتم وضع رمز امام الصف الذي تم ترحيله مثل : مرحل او تم او Dun او رقم او شرطة او أي شيء آخر بحيث يقوم الكود عند عمله بالتاكد من وجود الرمز امام الصف فاذا كان موجود الرمز لا يرحله و اذاكان الرمز غير موجود يتم ترحيل الصف ثم يضع امامه الرمز المطلوب لكي لا يتم ترحيله مره اخرى 3 الطريقة الاصعب يجب ان تحدد انت ماهو المتغير الذي لا يتكرر في بيانات أي صف مثل : رقم السند – نوع السند – الاسم ثم يتم تعديل الكود بحيث عند ذهابه للورقة التي مطلوب الترحيل لها يبحث في العمود المحدد الذي به المتغير الذي لا يتكرر – فاذا وجد هذا المتغير جود لا يرحل البيانات و اذا لم يكن موجود يقوم بترحيل البيانات الى الورقة المطلوبة مع التحيه آمل ان تكون وضحة الفكرة و عليك ان تحدد ماتريد

السلام عليكم و رحمة الله وبركاته تم استخدام الكود التالي Sub az_mokhtar() 'نقل البيانات Dim FS As Worksheet, TS As Worksheet Dim Q1, TR, FR, ER, SH Set FS = Sheets(ActiveSheet.Name) ER = 99 For FR = 12 To ER Q1 = FS.Cells(FR, 3).Text If Q1 = "" Then GoTo 9 For SH = 1 To ActiveWorkbook.Sheets.Count If Sheets(SH).Name = Q1 Then TR = Sheets(SH).[C65536].End(xlUp).Row + 1 For FC = 2 To 13 Sheets(SH).Cells(TR, FC) = FS.Cells(FR, FC) Next FC End If Next SH 9 Next 'FR '' End Sub جرب المرفق مع التحية و التقدير ترحيل بيانات.xlsm

آمين يارب انا و انت و جميع المسلمين شكرا لك على هذه الدعوات الجميله وجزاك الله خيرا

السلام عليكم و رحمة الله وبركاته تم عمل المطلوب مع رسالة عند تكرار الاسم Sub az_mokhtar() 'äÞá ÇáÈíÇäÇÊ Dim WB1 As Workbook, WB2 As Workbook Dim FS As Worksheet, TS As Worksheet Dim Q1, Q2, TR, TR2 Set WB1 = Workbooks(ActiveWorkbook.Name) Set FS = WB1.Sheets(ActiveSheet.Name) Q1 = FS.Range("J2").Text Workbooks.Open (Q1) 'Workbooks.Open "C:\Users\Ad\Desktop\ãÎÊÇÑ\mokhtar4 (1).xls" Set WB2 = Workbooks(ActiveWorkbook.Name) Set TS = WB2.Sheets(1) TR = TS.[a65536].End(xlUp).Row + 1 '' Q2 = FS.Cells(1, 2).Text For TR2 = 2 To TR If TS.Cells(TR2, 1) = Q2 Then MsgBox "ãæÌæÏ: " & Q2 & " - - ÕÝ= " & TR2 TR = TR2 GoTo 7 End If Next '' 7 TS.Cells(TR, 1) = FS.Cells(1, 2) TS.Cells(TR, 2) = FS.Cells(2, 3) TS.Cells(TR, 3) = FS.Cells(5, 4) TS.Cells(TR, 4) = FS.Cells(3, 3) TS.Cells(TR, 5) = FS.Cells(4, 3) TS.Cells(TR, 6) = FS.Cells(5, 3) TS.Cells(TR, 7) = FS.Cells(1, 7) TS.Cells(TR, 8) = FS.Cells(2, 7) WB2.Save WB2.Close FS.Activate End Sub شاهد المرفق مع التحية مختار.rar

السلام عليكم و رحمة الله و بركاته ما معنى كلمة تفعيل كل الفواتير ؟؟؟؟

السلام عليكم و رحمة الله وبركاته اولا : تضع اسم الملف المراد فتحه و المسار كاملا في الخلية J2 في الملف الرئيسي ثانيا : هذا الكود لعمل اللازم - على قدر فهمي لطلبك Sub az_mokhtar() 'نقل البيانات Dim WB1 As Workbook, WB2 As Workbook Dim FS As Worksheet, TS As Worksheet Dim Q1, TR Set WB1 = Workbooks(ActiveWorkbook.Name) Set FS = WB1.Sheets(ActiveSheet.Name) Q1 = FS.Range("J2").Text Workbooks.Open (Q1) 'Workbooks.Open "C:\Users\Ad\Desktop\مختار\mokhtar4 (1).xls" Set WB2 = Workbooks(ActiveWorkbook.Name) Set TS = WB2.Sheets(1) TR = TS.[a65536].End(xlUp).Row + 1 '' TS.Cells(TR, 1) = FS.Cells(1, 2) TS.Cells(TR, 2) = FS.Cells(2, 3) TS.Cells(TR, 3) = FS.Cells(5, 4) TS.Cells(TR, 4) = FS.Cells(3, 3) TS.Cells(TR, 5) = FS.Cells(4, 3) TS.Cells(TR, 6) = FS.Cells(5, 3) TS.Cells(TR, 7) = FS.Cells(1, 7) TS.Cells(TR, 8) = FS.Cells(2, 7) 'With TR ' .PasteSpecial xlValues ' .PasteSpecial xlFormats ' End With WB2.Save WB2.Close FS.Activate End Sub جرب المرفق جزاك الله خيرا مختار.rar

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

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

لا اظن ان الخطأ هنا اعتقد ان الخطأ يكون هنا حيث ان هنا هذا التعريف هو لفتح الملف ثم انت استخدمته كـ اسم للملف لذلك استبدل هذا السطر Set mokhtar4 = Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls" بما يلي Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls") Set mokhtar4 = ActiveWorkbook ان شاء الله رايحة تظبط معاك فضلا جرب و اعلمني بالنتيجة .... مع التحية

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

السلام عليكم اعتذر منك على التاخير كنت مريض كورونا و الان الحمد بخير لا يوجد لدي فيسبوك او تويتر

السلام عليكم و رحمة الله وبركاته تم اضافة عمود للمقاس تم عمل قائمة منسدلة للصنف تم عمل قائمة منسدلة للمقاس في g1 تم اضافة دالة للبحث عن كلمة بيع في نوع الفاتورة اذا وجد بيع - يقوم بخصم الكمايات لا يوجد بيع يقوم باضافة الكميات فقط زر واحد للعمليات اضافة او خصم حسب نوع الفاتورة مع التحية _البرنامج 1-7-2020 - نسخة (2).xls

العفو جزاك الله خيرا

السلام عليكم و رحمة الله وبركاته اخي الفاضل تم عمل الكود في حدث التغيير في الورقة لذلك فقط بمجرد كتابة رقم القائمة في الخلية الصفراء تظهر النتائج فورا Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$I$3" Then Q1 = Range(Target.Address).Value Range("B15:J39").ClearContents TR = 15 With Sheets("ÊÝÇÕíá ÇáãÈíÚÇÊ") For FR = 4 To 999 If .Cells(FR, 2) = Q1 Then Cells(8, 4) = .Cells(FR, 3) Cells(TR, 2) = .Cells(FR, 1) Cells(TR, 3) = .Cells(FR, 4) Cells(TR, 4) = .Cells(FR, 5) Cells(TR, 5) = .Cells(FR, 6) Cells(TR, 7) = .Cells(FR, 8) Cells(TR, 8) = .Cells(FR, 9) Cells(TR, 9) = .Cells(FR, 10) Cells(TR, 10) = .Cells(FR, 11) Cells(12, 9) = .Cells(FR, 12) Cells(10, 9) = .Cells(FR, 14) Cells(10, 4) = .Cells(FR, 15) Cells(12, 4) = .Cells(FR, 16) TR = TR + 1 End If Next FR End With Range(Target.Address).Select End If End Sub مرفق الملف ahmed1.xlsm

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

نفس الكود السابق انسخة ثم الصقه ثم غير اسم الكود ثم علامة + الوحيدة الموجودة في الكود استبدلها الى - ثم اربط الكود بزر الفاتورة للبيع .... مرفق ملف المخزنAZ02.xlsm

و عليكم السلام و رحمة الله وبركاته جرب توريد للمخزن في المرفق لعله المطلوب Sub ADDIN01() Dim FS As Worksheet, TS As Worksheet Dim Q1 Set FS = Sheets(ActiveSheet.Name) Set TS = Sheets("المخزن") For FR = 5 To 30 Q1 = FS.Cells(FR, 6).Value Q2 = FS.Cells(FR, 4) & "*" & FS.Cells(FR, 5) Q3 = FS.Cells(FR, 7).Value For TR = 3 To 999 If TS.Cells(TR, 2) = Q1 Then For TC = 3 To 33 If TS.Cells(2, TC) = Q2 Then TS.Cells(TR, TC) = TS.Cells(TR, TC) + Q3 GoTo 9 End If Next 'TC End If Next 'TR 9 Next ' FR End Sub المخزنAZ.xlsm

و عليكم السلام و رحمة الله وبركاته يجب تغيير اسماء الاوراق بما يتطابق تماما مع اسماء الاعمدة لكي يتم وضع كل بند في ورقته الكود موجود في حدث التغيير في الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row > 4 And Target.Column >= 4 _ And Target.Column < 20 Then For Q1 = 3 To Sheets.Count If Sheets(Q1).Name = Cells(3, Target.Column).Text _ Then GoTo 8 Next MsgBox "Nun" & Cells(3, Target.Column).Text GoTo 9 8 Set TS = Sheets(Cells(3, Target.Column).Text) Q1 = Cells(Target.Row, 22).Text Q2 = Cells(Target.Row, Target.Column).Value With TS For TR1 = 8 To 99 If .Cells(TR1, 5) = Q1 Then .Cells(TR1, 3) = Q2 GoTo 9 End If Next For TR2 = 8 To 99 If .Cells(TR2, 5) = "" Then .Cells(TR2, 5) = Q1 .Cells(TR2, 3) = Q2 GoTo 9 End If Next End With End If 9 End Sub مرفق الملف مع التحية اداري تعديل.xls

هذه مشكلة في الادخال حيث يتم ادخال الوقت بطريقة غير صحيحة لادخال الوقت يجب استخدام ( : ) وليس الفاصلة العشرية بمعنى عندما تريد ادخال 21 دقيقة تكتب هكذا 00:21 و ليس هكذا 0.21 مع التحية

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

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

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

السلام عليكم و رحمة الله وبركاته ابحث عن برنامج اسمه EXCEL RECAVERY هو مختص باصلاح برامج الاكسل لم اجد له سابقا اي نسخ مجانية

السلام عليكم و رحمة الله وبركاته اخي الفاضل استخدم الدالة التالية =HYPERLINK(CONCATENATE("#";ADDRESS(ROW();7;;;$E$1))) و اسحبها الى الاسفل ان شاء الله سوف تعمل معك كما فهمت من طلبك مع التحية

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