ابو حمادة قام بنشر أبريل 29, 2017 قام بنشر أبريل 29, 2017 (معدل) ولو امكن يكون فيه شرط لعدم تقرار نفس الشهر وعدم النقل لشهر الحالى قبلالشهر السابق بمعني عند نقل بيانات الصفحات المذكور لشهر فبراير مثلا قبل يناير تظهر رسااله تقول لا يمكن اضافه هذا الشهر قبل اضافة الشهر السابق وان كان الشهر اضيف سابقا لا يتم نسخ البيانات وتظهر رساله تقول انه تم اضافه هذا الشهر سابقا وجزاكم الله خيرا مرفق ملف للتوضيح والعمل عليه بيانات.rar تم تعديل أبريل 29, 2017 بواسطه ابو حمادة
ابراهيم الحداد قام بنشر أبريل 30, 2017 قام بنشر أبريل 30, 2017 السلام عليكم ورحمة الله انسخ هذا الكود والصقه فى موديول وخصص له زر Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then sh.Range("C6:BI32").Copy With ws LR = ws.Range("A" & Rows.Count).End(xlUp).Row If LR < 5 Then LR = 5 End If ws.Range("A" & LR + 1).PasteSpecial xlPasteValues For Each cel In ws.Range("BH6:BH" & Range("A" & Rows.Count).End(xlUp).Row) cel.Value = sm.Range("E1") cel.Offset(0, 1) = sm.Range("F1") .Range("A6").Select Next End With End If Next Application.CutCopyMode = True End Sub 1
ابو حمادة قام بنشر أبريل 30, 2017 الكاتب قام بنشر أبريل 30, 2017 (معدل) الف شكر ليك استاذ زيزو العجوز بس ليا رجاء ان يكون نسخ الشهر والسنه امام كل صف في به بيانات في صفحة ( ArchiveS ) ويكون فيه شرط لالا يتكرر نفس البيانات للشهر ولك منى الف تحيه تم تعديل أبريل 30, 2017 بواسطه ابو حمادة
ابراهيم الحداد قام بنشر أبريل 30, 2017 قام بنشر أبريل 30, 2017 السلام عليكم ورحمة الله استبدل الكود السابق بهذا الكود Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, x As Integer, cel As Range Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR + 1).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR + 1).Resize(x + 1) = sm.Range("F1") ws.Range("A6").Select Application.CutCopyMode = False End If Next End Sub 2
ابو حمادة قام بنشر أبريل 30, 2017 الكاتب قام بنشر أبريل 30, 2017 الله ينور استاذي الغالي زيزو العجوز باقي حاجه وهي اضافة شرط في حالة اني انسي اضيف اي شهر من الشهور عند اضافه الشهر التالي تظهر رساله تقول لابد من اضافة الشهر السابق اولا وان كنت ضفت هذا الشهر مره سابقه تظهر رساله بان لا يمكن اضافة هذا الشهر مره اخرى لنفس العام مثال ضفت شهر مارس للارشيف وجه شهر ابريل نسيت اضافته وجيت في شهر مايو مثلا اضيفه للارشيف كدا شهر ابريل لم يضاف للارشيف في هذه الحالهتظهر رساله باننىلابداناضيف شهر ابريل اولا ولا يمكن اضافه شهرمايو قبل اضافة شهر ابريل وهكذا عن كل شهر ولا يمكن اضافة شهر من الشهور لنفس السنه مرتين وان قمت انا لاضافة نفس الشهر في نفس السنه تظهر رسالة تفيد انه تم اضافة هذا الشهر سابقا ولك مني جزيل الشكر والاحترام
ابراهيم الحداد قام بنشر أبريل 30, 2017 قام بنشر أبريل 30, 2017 السلام عليكم ورحمة الله اتمنى ان يكون هذا الكود هو ما تصبو اليه ملحوظة هامة : عند كتابة الاشهر التى تبدأ بحرف " أ " تأكد من الهمزة على حرف الألف Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, LS As Long, S As Long, x As Integer, cel As Range Dim a As Integer, b As Integer, c As Integer Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False If sm.Range("E1") = "" Or sm.Range("F1") = "" Then MsgBox "من فضلك اكمل التاريخ اولا" Exit Sub End If LS = ws.Range("A" & Rows.Count).End(xlUp).Row If ws.Cells(LS, "BH") = sm.Range("E1") Then MsgBox " هذا الشهر سبق ادراجه بالفعل " Exit Sub End If a = Month(DateValue("01 " & sm.Range("E1").Value)) If ws.Range("BH" & LS) = "" Then b = 0 Else b = Month(DateValue("01 " & ws.Range("BH" & LS).Value)) End If c = a - b If c > 1 And ws.Range("BH" & LS) <> "" Then MsgBox " تأكد من اسم الشهر مرة اخرى يوجد شهر او اكثر غير مدرج" Exit Sub End If For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR).Resize(x + 1) = sm.Range("F1") Application.CutCopyMode = False End If Next End Sub 1
ابو حمادة قام بنشر مايو 1, 2017 الكاتب قام بنشر مايو 1, 2017 6 ساعات مضت, زيزو العجوز said: السلام عليكم ورحمة الله اتمنى ان يكون هذا الكود هو ما تصبو اليه ملحوظة هامة : عند كتابة الاشهر التى تبدأ بحرف " أ " تأكد من الهمزة على حرف الألف Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, LS As Long, S As Long, x As Integer, cel As Range Dim a As Integer, b As Integer, c As Integer Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False If sm.Range("E1") = "" Or sm.Range("F1") = "" Then MsgBox "من فضلك اكمل التاريخ اولا" Exit Sub End If LS = ws.Range("A" & Rows.Count).End(xlUp).Row If ws.Cells(LS, "BH") = sm.Range("E1") Then MsgBox " هذا الشهر سبق ادراجه بالفعل " Exit Sub End If a = Month(DateValue("01 " & sm.Range("E1").Value)) If ws.Range("BH" & LS) = "" Then b = 0 Else b = Month(DateValue("01 " & ws.Range("BH" & LS).Value)) End If c = a - b If c > 1 And ws.Range("BH" & LS) <> "" Then MsgBox " تأكد من اسم الشهر مرة اخرى يوجد شهر او اكثر غير مدرج" Exit Sub End If For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR).Resize(x + 1) = sm.Range("F1") Application.CutCopyMode = False End If Next End Sub تسلم حبيب قلبي الله ينور عليكاستاذي الغالي 6 ساعات مضت, زيزو العجوز said: السلام عليكم ورحمة الله اتمنى ان يكون هذا الكود هو ما تصبو اليه ملحوظة هامة : عند كتابة الاشهر التى تبدأ بحرف " أ " تأكد من الهمزة على حرف الألف Sub ADDToArchive() Dim ws As Worksheet, sh As Worksheet, sm As Worksheet Dim LR As Long, LS As Long, S As Long, x As Integer, cel As Range Dim a As Integer, b As Integer, c As Integer Set ws = ThisWorkbook.Sheets("ArchiveS") Set sm = ThisWorkbook.Sheets("مرايا للكشف") Application.ScreenUpdating = False If sm.Range("E1") = "" Or sm.Range("F1") = "" Then MsgBox "من فضلك اكمل التاريخ اولا" Exit Sub End If LS = ws.Range("A" & Rows.Count).End(xlUp).Row If ws.Cells(LS, "BH") = sm.Range("E1") Then MsgBox " هذا الشهر سبق ادراجه بالفعل " Exit Sub End If a = Month(DateValue("01 " & sm.Range("E1").Value)) If ws.Range("BH" & LS) = "" Then b = 0 Else b = Month(DateValue("01 " & ws.Range("BH" & LS).Value)) End If c = a - b If c > 1 And ws.Range("BH" & LS) <> "" Then MsgBox " تأكد من اسم الشهر مرة اخرى يوجد شهر او اكثر غير مدرج" Exit Sub End If For Each sh In ThisWorkbook.Worksheets If sh.Name <> "ArchiveS" And sh.Name <> "مرايا للكشف" And sh.Name <> "قوائم" Then x = WorksheetFunction.Count(sh.Range("C6:C32")) sh.Range("C6:BI32").Copy LR = ws.Range("A" & Rows.Count).End(xlUp).Row ws.Range("A" & LR + 1).PasteSpecial xlPasteValues ws.Range("BH" & LR).Resize(x + 1) = sm.Range("E1") ws.Range("BI" & LR).Resize(x + 1) = sm.Range("F1") Application.CutCopyMode = False End If Next End Sub الله ينور استاذي الغالي زيزو العجوز بجد انا عاجز عن شكرى ليك الكود بالفعل يعمل جيدا بس قبلتني مشكله عند اضافه شهر من الشهور لنفس السنه يعمل الكود جيدا ولكن عند اضافه نفس الشهر لسنه جديده بيرفض الاضافه هل ينفع ربط الشهر مع السنه بحيث عند اضافه الشهر لسنه اخرى يتم اضافته عادي مثال مارس 2017 لو تم تكراره يرفض الاضافه لكن لو مارس 2018 يتم اضافته عادي
ابراهيم الحداد قام بنشر مايو 1, 2017 قام بنشر مايو 1, 2017 السلام عليكم ورحمة الله استبدل هذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.Range("F1") Then 1
ابو حمادة قام بنشر مايو 1, 2017 الكاتب قام بنشر مايو 1, 2017 14 ساعات مضت, زيزو العجوز said: السلام عليكم ورحمة الله استبدل هذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر : If c > 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.Range("F1") Then اخي ااااالفاضل استاذ زيزو العجوز رجاء واسف لو كنت تقلت علي حضرتك الملف الاصلي البيانات.rar
ابراهيم الحداد قام بنشر مايو 2, 2017 قام بنشر مايو 2, 2017 السلام عليكم ورحمة الله تم تنفيذ المطلوب بفضل الله تم تغيير الورقة ارشيف بورقة اخرى فيرجى اعادة تنسيقها مرة اخرى اذا اردت لا تترك بيانات رؤوس الجداول فارغة حتى يعمل مع الكود بدون منغصات هذا وبالله التوفيق اليك الملف البيانات.rar 1
ابو حمادة قام بنشر مايو 2, 2017 الكاتب قام بنشر مايو 2, 2017 2 ساعات مضت, زيزو العجوز said: السلام عليكم ورحمة الله تم تنفيذ المطلوب بفضل الله تم تغيير الورقة ارشيف بورقة اخرى فيرجى اعادة تنسيقها مرة اخرى اذا اردت لا تترك بيانات رؤوس الجداول فارغة حتى يعمل مع الكود بدون منغصات هذا وبالله التوفيق اليك الملف البيانات.rar بصراحه انا عاجز عن الشكر استاذي الفاضل وبصراحه حاسس انى تقلت علىك جدا يريت تعذرني بس يريت تجربه انت وتلاحظ النتيجه هناك مشكله في تكرار الشهور وايضا اضافه شهر الحالي قبل الشهر السابق انا ضفت شهر فبراير ولما حبيت اجرب الكود جربت اضيف شهر ابريل قبل شهر مارس وللاسف تم اضافه شهر ابريل بالرغم ان شهر مارس لم يضاف اناا عايز لو حصل سهو وحبيت اضيف شهر من الشهور ولم يسبق لي اضافه الشهر السابق يرفض الاضافه الى في حالة وحده تغيير السنه ولك مني الف تحيه
ابراهيم الحداد قام بنشر مايو 2, 2017 قام بنشر مايو 2, 2017 (معدل) السلام عليكم ورحمة الله اخى الكريم لا شكر على واجب والله فى عون العبد ما دام العبد عون اخيه تفضل تم اصلاح المطلوب البيانات.rar تم تعديل مايو 2, 2017 بواسطه زيزو العجوز 1
ابو حمادة قام بنشر مايو 2, 2017 الكاتب قام بنشر مايو 2, 2017 (معدل) 1 ساعه مضت, زيزو العجوز said: السلام عليكم ورحمة الله اخى الكريم لا شكر على واجب والله فى عون العبد ما دام العبد عون اخيه تفضل تم اصلاح المطلوب البيانات.rar جزاك الله خير استاذي الغالي كدا اغلب مشاكل الكود اتحلت بالفعل الله ينور باقي ملحوظه واحده فقط هي حاول تجرب تضيف للارشيف الشهور من شهر يناير 2017 حتى ديسمبر 2017 ثم حاول تضيف شهر يناير 2018 سوف يرفض الاضافه وتظهر رساله تقول انه تمت اضافه هذا الشهر سابقا مع ان هذا يعتبر شهر جديد لم يضاف سابقا ولك منى الف تحيه واسف جدا انى تعبتك معايام ولو كاان هذا الامر صعب تنفيذه ممكن يتم دمج الشهر مع السنه في عمود واحد بحيث يكون هناك تغيير لاسم الشهر بحيث يكون اضافه الشهر والسنه لنفس العمود بهذه الطريقه يناير/2017 فبراير/2017 مارس/2017 بدلا من اضافه الشهر في عمود والسنه في عمود اخر بحيث عند اضافه نفس الشهر لسنه اخري سوف يكون بهذا الشكل يناير/2018 فبراير/2018 مارس/2018 تم تعديل مايو 2, 2017 بواسطه ابو حمادة
ابراهيم الحداد قام بنشر مايو 2, 2017 قام بنشر مايو 2, 2017 السلام عليكم ورحمة الله استبدل هذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value Then بهذا السطر If ws.Cells(LS, "BH") = sm.OLEObjects("Combobox1").Object.Value And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then واستبدل هذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" Then بهذا السطر If c <> 1 And ws.Range("BH" & LS) <> "" And ws.Range("BI" & LS) = sm.OLEObjects("Combobox2").Object.Value Then
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.