اذهب الي المحتوي
أوفيسنا

تجميع بيانات من اكثر من صفحه لصفحه واحدة


الردود الموصى بها

 

 

Capture.PNG.03c7b21576086a3eea82f438a351a298.PNG

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

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

وان كان الشهر اضيف سابقا لا يتم نسخ البيانات وتظهر رساله تقول انه تم اضافه هذا الشهر سابقا

وجزاكم الله خيرا

مرفق ملف للتوضيح والعمل عليه

بيانات.rar

 

تم تعديل بواسطه ابو حمادة
رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

انسخ هذا الكود والصقه فى موديول وخصص له زر

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

 

  • Like 1
رابط هذا التعليق
شارك

الف شكر ليك استاذ زيزو العجوز

بس ليا رجاء

ان يكون نسخ الشهر والسنه امام كل صف في به بيانات في صفحة ( ArchiveS )

ويكون فيه شرط لالا يتكرر نفس البيانات للشهر 

ولك منى الف تحيه

 

 

تم تعديل بواسطه ابو حمادة
رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

استبدل الكود السابق بهذا الكود

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

 

  • Like 2
رابط هذا التعليق
شارك

الله ينور استاذي الغالي  زيزو العجوز

باقي حاجه وهي

اضافة شرط  

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

مثال

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

ولا يمكن اضافة شهر من الشهور لنفس السنه مرتين وان قمت انا لاضافة نفس الشهر في نفس السنه تظهر رسالة تفيد انه تم اضافة هذا الشهر سابقا

ولك مني جزيل الشكر والاحترام

 

 

رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

اتمنى ان يكون هذا الكود هو ما تصبو اليه

ملحوظة هامة : عند كتابة الاشهر التى تبدأ بحرف " أ " تأكد من الهمزة على حرف الألف

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

 

  • Like 1
رابط هذا التعليق
شارك

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  يتم اضافته عادي

 

رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

استبدل هذا السطر  :

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

 

  • Like 1
رابط هذا التعليق
شارك

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

03.PNG.bb30b8db6d6d863fe89befa26a7e508a.PNG

رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

تم تنفيذ المطلوب بفضل الله

تم تغيير الورقة ارشيف بورقة اخرى فيرجى اعادة تنسيقها مرة اخرى اذا اردت

لا تترك بيانات رؤوس الجداول فارغة حتى يعمل مع الكود بدون منغصات

هذا وبالله التوفيق

اليك الملف

 

البيانات.rar

  • Like 1
رابط هذا التعليق
شارك

2 ساعات مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

تم تنفيذ المطلوب بفضل الله

تم تغيير الورقة ارشيف بورقة اخرى فيرجى اعادة تنسيقها مرة اخرى اذا اردت

لا تترك بيانات رؤوس الجداول فارغة حتى يعمل مع الكود بدون منغصات

هذا وبالله التوفيق

اليك الملف

 

البيانات.rar

بصراحه انا عاجز عن الشكر استاذي الفاضل وبصراحه حاسس انى تقلت علىك جدا  يريت تعذرني

بس يريت تجربه انت وتلاحظ النتيجه  هناك مشكله في تكرار الشهور وايضا اضافه شهر الحالي قبل  الشهر السابق 

انا ضفت شهر فبراير ولما  حبيت اجرب الكود جربت  اضيف شهر ابريل قبل شهر مارس وللاسف تم اضافه شهر ابريل بالرغم ان شهر مارس  لم يضاف

اناا عايز لو  حصل سهو وحبيت اضيف  شهر من الشهور  ولم يسبق لي  اضافه الشهر السابق يرفض الاضافه الى في  حالة وحده تغيير السنه 

ولك مني الف تحيه

 

رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

اخى الكريم لا شكر على واجب

والله فى عون العبد ما دام العبد عون اخيه

تفضل تم اصلاح المطلوب

 

البيانات.rar

تم تعديل بواسطه زيزو العجوز
  • Like 1
رابط هذا التعليق
شارك

1 ساعه مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

اخى الكريم لا شكر على واجب

والله فى عون العبد ما دام العبد عون اخيه

تفضل تم اصلاح المطلوب

 

البيانات.rar

جزاك الله خير استاذي الغالي كدا اغلب مشاكل الكود اتحلت بالفعل الله ينور باقي ملحوظه واحده فقط

هي

حاول تجرب  تضيف للارشيف الشهور من شهر يناير 2017 حتى ديسمبر 2017

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

ولو كاان هذا الامر صعب تنفيذه ممكن يتم دمج  الشهر مع السنه في عمود واحد بحيث يكون هناك تغيير لاسم الشهر  بحيث يكون اضافه الشهر والسنه لنفس العمود

بهذه الطريقه يناير/2017 فبراير/2017 مارس/2017

بدلا من اضافه الشهر في عمود والسنه في عمود اخر

بحيث عند اضافه نفس الشهر لسنه اخري سوف يكون بهذا الشكل 

يناير/2018 فبراير/2018 مارس/2018
 

تم تعديل بواسطه ابو حمادة
رابط هذا التعليق
شارك

السلام عليكم ورحمة الله

استبدل هذا السطر

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.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information