مساعدة من الإخوة الأفاضل في الترحيل مع مسح البيانات المرحلة

[طبعي الود]

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

كشف يومية الفرع.xlsx

[ابراهيم الحداد]

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

استخدم هذا الكود

Sub TraData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, ShName
Set ws = Sheets("يناير ")
ShName = Day(ws.Range("J3"))
ws.Range("A1:K50").Copy
On Error Resume Next
If Len(Trim(ShName)) > 0 Then
If Len(Sheets(ShName).Name) = 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = ShName
End If
End If
Sheets(ShName).Range("A1").Select
Selection.PasteSpecial xlPasteAll
Selection.PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
End Sub

 

[طبعي الود]

شاكرين ومقدرين تفاعلك وأسأل الله أن ينفع بك وبعلمك  وأشهد إنك ( أستاذ )

لدي طلب بسيط فهل نستطيع أن نظيف امر او كود يمسح البيانات من ورقة الادخال الأولى لكي ادخل بيانات جديدة

[ابراهيم الحداد]

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

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

لذا ارجو ان تستبدل الكود السابق بما يلى

اولا يجب ربط الزر (زر الترحيل) بالكود التالى

Sub AddSheet()
Dim ws As Worksheet, Obj As Object
Dim Itm As Variant, C As Range
Dim x As Integer
Set ws = Sheets("يناير ")
Set Obj = CreateObject("Scripting.Dictionary")
Set C = ws.Range("J3")
x = VBA.Day(C.Value)

If Not Obj.exists(x) Then
Obj.Add x, x
End If

For Each Itm In Obj.keys
If Not ShExists(Obj(Itm)) Then
Sheets.Add(After:=Sheets(Sheets.Count)).Name = Itm
End If
Next
Call TraData
End Sub

ثانيا نسخ ولصق الكود و الدالة المعرفة التاليين فى موديول مستقل داخل الملف ايضا ولا تربط ايا منهما بأى زر

الكود هو

Sub TraData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, ShName
Set ws = Sheets("يناير ")
ShName = Day(ws.Range("J3"))
ws.Range("A1:K50").Copy
For Each Sh In Worksheets
If Sh.Name = ShName Then
Sh.Range("A1").Select
Selection.PasteSpecial xlPasteAll
Selection.PasteSpecial xlPasteColumnWidths
End If
Next
Application.CutCopyMode = False
End Sub

و الدالة هى

Function ShExists(ShNam As String, Optional WB As Workbook) As Boolean
    Dim Sh As Worksheet
     If WB Is Nothing Then Set WB = ThisWorkbook
     On Error Resume Next
     Set Sh = WB.Sheets(ShNam)
     On Error GoTo 0
     ShExists = Not Sh Is Nothing
 End Function

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

[ابراهيم الحداد]

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

ضف هذه العبارة الى اخر سطر فى الكود المسمى  TraData 

ws.Range("A1:K50").ClearContents

 

[طبعي الود]

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

ShName = Day(ws.Range("J3"))

[ابراهيم الحداد]

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

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

اما العبارة السابقة اسم الشيت الذى سترحل اليه البيانات وهذه الخلية J3 تحوى تارخ شهرى وعرضه بهذه الطريقة

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

و الله الموفق و المستعان