طارق محمود

السلام عليكم أخي العزيز سأغلق هذا الموضوع لأنه مكرر في الموضوع الأول علي الرابط http://www.officena.net/ib/index.php?showtopic=39283

السلام عليكم أخي : أرسل الملفين لي

السلام عليكم أخي الفاضل تأكد أن الملفين في نفس المجلد وأن إسم الشيتات الذي أضفتها هو نفسه في الملفين وإلا أرسل الملفين لي

السلام عليكم أخي جرب الكود التالي علي أساس أن الورقة الأولي إسمها TOTAL Sub Tareq_ترحيل() Range("A4:K60000").ClearContents For Sh = 2 To Sheets.Count R = Sheets(Sh).[B10000].End(xlUp).Row Range(Sheets(Sh).[b2], Sheets(Sh).Cells(R, "K")).Copy Sheets("TOTAL").[B60000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues Next Sh Application.CutCopyMode = False MsgBox ("!تم الترحيل بنجاح") [A4] = 1 For i = 2 To [B60000].End(xlUp).Row - 3 Cells(i + 3, 1) = i Next i [A2].Select End Sub وتفضل هذا ملفك مرفق وبه الكود علي الرابط التالي http://www.4shared.com/file/pwR89h_W/2_online.html

السلام عليكم أخي العزيز /أباالحسن رفق الحل بالكود كما طلبت بشرط ان يكون الملفين في نفس المجلد وهذا هو الكود للمطالعة Sub AbulHassan() f1Name = ActiveWorkbook.Name pth = ActiveWorkbook.Path f2Name = "الارتباطات.xls" file2 = pth & "\" & f2Name 'مسح البيانات القديمة Range("B2:O4").ClearContents On Error Resume Next 'الجزء التالي يفتح ملف الارتباطات إن لم يكن مفتوحا مع أخذ الإحتمال ان يكون ملف الارتباطات مفتوح بالفعل Set F_check = Excel.Workbooks(f2Name) If Err = 0 Then GoTo 10 Workbooks.Open Filename:=file2 10 'الذهاب لملف الارتباطات وتحديد وترحيل القيم التي توافق الإجمالي فقط Workbooks(f2Name).Activate For sh = 1 To Worksheets.Count For a = 5 To Sheets(sh).[b1000].End(xlUp).Row If Sheets(sh).Cells(a, 2) = "الاجمالى" Then m = Month(Sheets(sh).Cells(a, 1)) ' معرفة الإسم العربي للشهر Select Case m Case 1: mA = "يناير" Case 2: mA = "فبراير" Case 3: mA = "مارس" Case 4: mA = "أبريل" Case 5: mA = "مايو" Case 6: mA = "يونيو" Case 7: mA = "يوليو" Case 8: mA = "اغسطس" Case 9: mA = "سبتمبر" Case 10: mA = "اكتوبر" Case 11: mA = "نوفمبر" Case 12: mA = "ديسمبر" End Select s = WorksheetFunction.Sum(Sheets(sh).Range("E" & a & ":" & "H" & a)) cc = WorksheetFunction.Match(mA, Workbooks(f1Name).Sheets(1).Range("1:1"), 0) rr = WorksheetFunction.Match(sh, Workbooks(f1Name).Sheets(1).Range("A:A"), 0) Workbooks(f1Name).Sheets(1).Cells(rr, cc) = s End If Next a Next sh 'رسالة بالبيانات المرحلة Workbooks(f1Name).Activate [a1].Select MsgBox ("تم الترحيل بنجاح") End Sub تقرير_2.rar

السلام عليكم أخي العزيز سنأخذ من مشاركة أخونا جمال دغيدي هذه اللفتة الجميلة لتحديد سنة العمل وبداية الشهر في الورقة صفر عن طريق شكل Control السهمين وأضفنا إليها إرتباط لجميع الشيتات بمعني أن تغيير السهم في الورقة 0 سيغير كل الورقات لنفس السنة وايضا تم تغيير معادلات العمود الأول والثاني ليتم حساب اليوم أوتوماتيكيا حسب السنة والشهر لكل ورقة تم عمل حل بسيط في الورقة 1 فقط إذا أعجبك ننسخه للباقي تم حله في ورقة ملخص ، الصف 20 (اللون الأصفر) أنظر المرفق يبدو أن التحميل به مشكلة عندي إذهب للرابط http://www.4shared.com/file/qJZpsGv2/MASTER0_3.html ومعا لبقية الطلبات فيما بعد

تمام الحمد لله

السلام عليكم أخي الحبيب mhrrd هذا البرنامج For a = 11 To [U3000].End(xlUp).Row If Cells(a, 21) <> "" Then MySheets = Cells(a, 21) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a يقوم بنفس عمل هذا For a = 11 To [a3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) With Sheets(MySheets).[a3000].End(xlUp) .Offset(1, 0) = Cells(a, 1) .Offset(1, 1) = Cells(a, 2) .Offset(1, 2) = Cells(a, 3) .Offset(1, 3) = Cells(a, 4) .Offset(1, 4) = Cells(a, 5) .Offset(1, 5) = Cells(a, 6) .Offset(1, 6) = Cells(a, 7) .Offset(1, 7) = Cells(a, 8) .Offset(1, 8) = Cells(a, 9) .Offset(1, 9) = Cells(a, 10) .Offset(1, 10) = Cells(a, 11) .Offset(1, 11) = Cells(a, 12) .Offset(1, 12) = Cells(a, 13) .Offset(1, 13) = Cells(a, 14) .Offset(1, 14) = Cells(a, 15) .Offset(1, 15) = Cells(a, 16) .Offset(1, 16) = Cells(a, 17) .Offset(1, 17) = Cells(a, 18) .Offset(1, 18) = Cells(a, 19) .Offset(1, 19) = Cells(a, 20) .Offset(1, 20) = Cells(a, 21) .Offset(1, 21) = Cells(a, 22) .Offset(1, 22) = Cells(a, 23) .Offset(1, 23) = Cells(a, 24) .Offset(1, 24) = Cells(a, 25) .Offset(1, 25) = Cells(a, 26) .Offset(1, 26) = Cells(a, 27) .Offset(1, 27) = Cells(a, 28) .Offset(1, 28) = Cells(a, 29) .Offset(1, 29) = Cells(a, 30) .Offset(1, 30) = Cells(a, 31) .Offset(1, 31) = Cells(a, 32) .Offset(1, 32) = Cells(a, 33) .Offset(1, 33) = Cells(a, 34) .Offset(1, 34) = Cells(a, 35) .Offset(1, 35) = Cells(a, 36) .Offset(1, 36) = Cells(a, 37) .Offset(1, 37) = Cells(a, 38) .Offset(1, 38) = Cells(a, 39) .Offset(1, 39) = Cells(a, 40) End With End If ' If Sheets("ورقة1").Cells(a, "a") > "" Then Cells(a, 3).Resize(1, 4).Value = "" ' اذا اردت مسح البيانات بعد الترحيل حفز هذا السطر Next a بالإضافة لإختلاف عمود المعيار من A إلي U أرجو قراءة ودراسة المشاركة رقم 28 جيدا إن شاء الله تجد ماتريد

السلام عليكم أخي الكريم / الشهابي أشكرك كثيرا لمروك الطيب وكلماتك العطرة تقبل ودي

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

السلام عليكم تفضل اخي المرفق بشرط ان يكون الملفين في نفس المجلد وهذا هو الكود بالتفصيل Sub T_shift() file1 = ActiveWorkbook.Name pth = ActiveWorkbook.Path f2Name = "قاعدة بيانات.xls" file2 = pth & "\" & f2Name On Error Resume Next 'إحتياطي لإحتمال ان يكون ملف قاعدة بيانات مفتوح بالفعل Set F_check = Excel.Workbooks(f2Name) If Err = 0 Then GoTo 10 Workbooks.Open Filename:=file2 10 'وضع خط أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous Workbooks(f2Name).Sheets(1).[a1].Select Workbooks(file1).Activate ' نسخ قيم فقط للبيانات التي توافق الشرط For a = 2 To [G1000].End(xlUp).Row If Cells(a, 7) = "يعتمد" Then Range(Cells(a, 1), Cells(a, 7)).Copy Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues ic = ic + 1 End If Next a Application.CutCopyMode = False 'وضع خط مرة أخري أسفل آخر قيم في ملف قاعدة بيانات rr = Workbooks(f2Name).Sheets(1).[A1000].End(xlUp).Row Workbooks(f2Name).Sheets(1).Range("A" & rr & ":G" & rr).Borders(xlEdgeBottom).LineStyle = xlContinuous 'رسالة بالبيانات المرحلة MsgBox (" تم ترحيل عدد" & ic & " بيان معتمد بنجاح") [a1].Select Workbooks(f2Name).Activate Range("A" & rr + 1).Select 'رسالة أخري من ملف قاعدة بيانات للتأكيد MsgBox "!تمام", vbInformation + vbMsgBoxRight, "تم الترحيل" Workbooks(file1).Activate End Sub ترحيل_TAREQ.rar

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

السلام عليكم أخي العزيز كما تعرف أن الطلبات كثيرة ولذلك فالأفضل معالجتها واحدة بواحدة علي مهل الأول تم عمل ذلك لكل الصفحات وأيضا إضافة تعريف تلقائي ليومي الجمعة والسبت حسب موقعهما من الشهر الثاني لم أستطع حلها الثالث تم حلها الرابع تكتب هذه القيمة 3 ساعات قبل موعد الخروج حسب معادلاتك الأفضل توضيح ماذا تريد ان يكتب إن خرج العامل أو الموظف 3 ساعات مثلا قبل الموعد عذرا لضيق وقتي ولاحقا سأري باقي الطلبات إن لم يتدخل أحد الإخوة تفضل المرفق به ماتيسر MASTER0_2.rar

الحمد لله والشكر لله

السلام عليكم أخي العزيز في أول الكود جزء بعنوان الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول لو دققت فيه فهذا الجزء يكون نسخة غير مكررة عن طريق التصفية المتقدمة للعمود الذي به نتائج وكان يضعها مؤقتا في العمود X ثم نلغي هذه القيم بعد حفظ الأسماء في المتغير sht(i) وحيث أنك أخبرتني في ان البيانات ستمتد إلي العمود Y ساعتها عدلت لك الكود للعمود Y ولكن في المرفق البيانات في العمود U وليس العمود Y عموما العمود U رقمه 21 في الشيت وهذا يفسر لك وجود الرقم 21 في الكود بدلا من الرقم 1 في الكود القديم وكذلك عدلت قليلا في الجزء الأخير (ضبط المسلسل في الشيتات التي حدث الترحيل إليها) لكي يتم التعامل مع العمود الذي به المسلسل A وليس B إليك الكود الجديد Sub Tareqتعديل_ترحيل() '============================================= On Error Resume Next Application.ScreenUpdating = False 'الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول rg1 = "U11:U" & [U3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("GX11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = Cells(1000, 206).End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "GX") Next i Range("GX11:GX" & 12 + case_NO).ClearContents 'الجزء التالي يمسح فقط المجال المطلوب من الشيتات التي أسماؤها مسجلة في الجزء السابق For sh = 1 To Sheets.Count For i = 1 To case_NO If Sheets(sh).Name = sht(i) Then Sheets(sh).Range("A11:U3000").ClearContents Next i Next sh 'وهناأصل البرنامج For a = 11 To [U3000].End(xlUp).Row If Cells(a, 21) <> "" Then MySheets = Cells(a, 21) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" ' وهنا تطوير طفيف ليلائم العدد المتغير للحالات For i = 1 To case_NO x(i) = Sheets(sht(i)).[A3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & x(i) & " " & sht(i) Next i MsgBox (" تم ترحيل عدد" & mssg) Range("a1").Select ' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها For i = 1 To case_NO Sheets(sht(i)).[A11] = 1 rrw = Sheets(sht(i)).[A3000].End(xlUp).Row For Each cc In Sheets(sht(i)).Range("A12:A" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next i On Error Resume Next On Error GoTo 0 End Sub والمرفق بعد التعديل تعديل ترحيل3.rar

السلام عليكم تقصد أن النتيجة التي عنوانها نتيجة الطالبة للترحيل للشيت المناسب ستكون بعمود آخر والذي به النتائج مثل: ناجحة ومنقولة ، لها دور ثان ، ....ليس لها حق الإعادة وليكن Y كما فرضت سيتطلب أيضا تعديل صدر الكود لإستخدام عمود بديل في التصفية غير السابق الذي كان X وليكن في أقصي اليسار GX مثلا بدلا من X وعلي ذلك يبدأ الكود بــ rg1 = "Y11:Y" & [Y3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("GX11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = [x100].End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "GX") Next i Range("GX11:GX" & 12 + case_NO).ClearContents إن وجدت صعوبة إرسل لي مثالا به البيانات بالشكل المطلوب

السلام عليكم أخي العزيز / mhrrd التغيير يكون في هذه الجزئية 'وهناأصل البرنامج For a = 11 To [A3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a Range(Cells(a, 1), Cells(a, 40)).Copy ' هذا السطر يأخذ نسخة من العمود الأول للعمود الأربعين Range(Cells(a, 1), Cells(a, 7)).Copy ' يمكنك إستبدال الرقم 40 بالرقم الذي تريد في حالة أن يكون المطلوب نقل أول أعمدة مثلا من الأول للسابع ' ولكن إن كنت تريد نقل أجزاء متفرقة مثلا الأعمدة من الأول للسابع مع الأعمدة من العشرين للخامس والعشرين فتغيره بما يلي Union(Range(Cells(a, 1), Cells(a, 7)), Range(Cells(a, 20), Cells(2, 25))).Copy أرجو تكون الفكرة واضحة

السلام عليكم اخي يوسف فقط عدل الجزء الأخير من الكود بدلا من ' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها For i = 1 To case_NO Sheets(sht(i)).[B11] = 1 For Each cc In Sheets(sht(i)).Range("B12:B" & [B3000].End(xlUp).Row) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next i ليكون ' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها For i = 1 To case_NO Sheets(sht(i)).[B11] = 1 rrw = Sheets(sht(i)).[B3000].End(xlUp).Row For Each cc In Sheets(sht(i)).Range("B12:B" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next i

السلام عليكم أخي الحبيب هذا هو الكود بعد التعديل Sub Tareqتعديل_ترحيل() '============================================= On Error Resume Next Application.ScreenUpdating = False 'الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول rg1 = "A11:A" & [A3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("X11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = [x100].End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "X") Next i Range("X11:X" & 12 + case_NO).ClearContents 'الجزء التالي يمسح فقط المجال المطلوب من الشيتات التي أسماؤها مسجلة في الجزء السابق For sh = 1 To Sheets.Count For i = 1 To case_NO If Sheets(sh).Name = sht(i) Then Sheets(sh).Range("A11:U3000").ClearContents Next i Next sh 'وهناأصل البرنامج For a = 11 To [A3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" ' وهنا تطوير طفيف ليلائم العدد المتغير للحالات For i = 1 To case_NO x(i) = Sheets(sht(i)).[A3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & x(i) & " " & sht(i) Next i MsgBox (" تم ترحيل عدد" & mssg) Range("a1").Select ' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها For i = 1 To case_NO Sheets(sht(i)).[B11] = 1 For Each cc In Sheets(sht(i)).Range("B12:B" & [B3000].End(xlUp).Row) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next i On Error Resume Next On Error GoTo 0 End Sub وهذا المرفق تفضل ترحيل معدل بدون مسح2.rar

السلام عليكم الدالة CHR في الفيجوال بيزيك هي نفسها CHAR في الإكسيل وهي ترجع عادة شكل الحرف أو الرقم الذي كوده يساوي كذا وهي تستخدم أيضا للأحرف الخاصة أو التحكم مثلا الحرف رقم 10 كما في مثالنا يفعل فعل كبسة الإنتر Enter بمعني أن إذا لديك بيانين في الطباعة كما في حالنا هذا وتريد لكل بيان منهما أن يظهر في سطر منفصل في الصندوق الحواري MSG فتضع بينهما & Chr(10) &

السلام عليكم أولا غير نوع الشارت من Line إلي Scatter وذلك عن طريق كليك يمين علي الشارت ثم Change Chart Type هذا النوع من الشارت Scatter هو الذي يسمح بتغير مقياس الرسم تبعا لقيمة المحور السيني سيظهر لك الرسم بشكل مختلف لتأثره بقيمة X ثانيا كليك يسار علي المحور السيني لتحديده اولا ثم كليك يمين وإختر آخر خيار Format Axis ومنها ستجد خيار المقاس اللوغاريتمي

السلام عليكم أخي الحبيب لايوجد مرفق !!!! لكن أنظر الفيديو المرفق ، عسي أن تجد به ماتريد Logaritmic_Scale.rar

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

السلام عليكم الحمد لله سهلة إن شاء الله ولكن ليس عندي وقت قبل السبت صبر جميل كنت سأطلب منك ذلك ، الحمد لله سهلة أيضا إن شاء الله ولكن إلي السبت

السلام عليكم أخي الحبيب تفضل المرفق وبه كود معدل2 وإليك الملاحظات التالية (1) قللت لك كثيرا في البيانات لتقليل وقت التنفيذ وتصغير حجم الملف ، يمكنك تزويدها كما تشاء (2) هذه الأسطر الأربعة في أول الكود ستمسح المجال A11:U3000 في جميع شيتات الملف فيما عدا شيت النتيجة كاملة For sh = 1 To Sheets.Count If Sheets(sh).Name = "النتيجة كاملة" Then GoTo 10 Sheets(sh).Range("A11:U3000").ClearContents 10 Next sh (3) وهذا إختصار لكود الأستاذ الجليل خبور خير وقد جربته ويعمل بنجاح For a = 11 To [a3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[a3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" (4) وهذه الأسطر القادمة تخبرك بعدد ماتم نقله x1 = Sheets("ناجحة ومنقولة").[a3000].End(xlUp).Row - 10 x2 = Sheets("لها دور ثان").[a3000].End(xlUp).Row - 10 MsgBox ("تم ترحيل عدد " & x1 & " طالبة لناجحة ومنقولة" & Chr(10) & "وترحيل عدد " & x2 & "طالبة لها دور ثان ") (5) طلبك الأخير لم أفهمه تحديد إسم العمود أو رقمه الذى يحتوى الدليل أو البيان الذى سيستخدم للترحيل تفضل المرفق ترحيل معدل_طارق.rar