نجوم المشاركات

وعليكم السلام جرب الملف المرفق Sub SaveWorkbookWithPasswordMonthYear() Dim originalWorkbook As Workbook Dim newWorkbook As Workbook Dim newFilePath As String Dim password As String Dim monthYear As String ' تعيين الملف الأصلي Set originalWorkbook = ThisWorkbook ' الحصول على اسم الشهر والسنة الحاليين monthYear = Format(Date, "mmmm yyyy") ' تحديد مسار الملف الجديد مع اسم الشهر والسنة newFilePath = Application.GetSaveAsFilename(InitialFileName:=monthYear & ".xlsb", FileFilter:="Excel Files (*.xlsb), *.xlsb") ' تعيين كلمة المرور password = InputBox("أدخل كلمة المرور للملف الجديد:") ' حفظ نسخة من الملف الأصلي originalWorkbook.SaveCopyAs newFilePath ' فتح النسخة الجديدة Set newWorkbook = Workbooks.Open(newFilePath) ' حفظ النسخة الجديدة مع كلمة المرور newWorkbook.SaveAs Filename:=newFilePath, password:=password ' إغلاق النسخة الجديدة newWorkbook.Close SaveChanges:=True MsgBox "تم حفظ النسخة الجديدة باسم الشهر والسنة وكلمة المرور بنجاح!" End Sub سلف شهر 8.xlsb

مطلوب تعديل الكود اسفل زرار نسخه احتياطيه لانه مش بيشتغل و كمان عايزه كود ضغـــط وإصــلاح البرنامـــج وكود إستعـــــادة نسخة إحتياطية New Microsoft Access Database.accdb

تفضل أخي الكريم تم استعمال نفس فكرة اليومي والخصم في نفس يوم تاريخ البداية مع اختلاف الشهور بالتوفيق خصم يومي أو شهري تلقائي .xlsx

الاخ الكريم موسى 🌷🌷🌷🌷 بصراحة و خلية سر بينى و بينك اخد لفة و قولت ياراجل .... لف مع اللى ادك ...... دى لف الناس الكبار اوى و لكن مع علمك و تواضعك ركزت اوى و بحث جدا لدرجة انى وصلت لل YouTube ليكسر حواجز و استفسارات كنت اظنها محتاجة وقت كتير و الاضافة الجديدة انك محاضر تمتلك ادوات توصيل المعلومة مبدع انتظرنى مع وعدك بالصبر و طول البال اشكرك اخى الكريم موسى

شكرا لك اخى عبدالله بشير عبدالله جزاك الله كل خير

شكرا لك معلمنا محمد صالح الكود بواسطة الذكاء الاصطناعي

تفضل أخي الكريم البحث عن )2(قيمة.xlsm

وعليكم السلام ورحمة الله وبركاته، نعم، يمكن القيام بذلك باستخدام VBA في Excel. إليك كود VBA الذي يمكنك استخدامه لتقسيم البيانات إلى ملفات منفصلة كل 30 صف: افتح ملف Excel واضغط على Alt + F11 لفتح محرر VBA. أدخل الكود التالي في وحدة جديدة: Sub SplitDataIntoFiles() Dim ws As Worksheet Dim newWs As Worksheet Dim wb As Workbook Dim newWb As Workbook Dim lastRow As Long Dim i As Long Dim j As Long Dim filePath As String Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من أن اسم الورقة صحيح lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row filePath = ThisWorkbook.Path & "\" j = 1 For i = 1 To lastRow Step 30 Set newWb = Workbooks.Add Set newWs = newWb.Sheets(1) ws.Rows(i & ":" & i + 29).Copy Destination:=newWs.Rows(1) newWb.SaveAs filePath & "Data_" & j & ".xlsx" newWb.Close SaveChanges:=False j = j + 1 Next i MsgBox "تم تقسيم البيانات بنجاح!",,"mr-mas.com" End Sub قم بتعديل اسم الورقة في السطر Set ws = ThisWorkbook.Sheets("Sheet1") إذا كان مختلفًا. اضغط على F5 لتشغيل الكود. سيقوم هذا الكود بتقسيم البيانات إلى ملفات منفصلة كل 30 صف وحفظها في نفس مسار الملف الأصلي. بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا بمكنك حدف السطور المخصصة للتحقق من أوراق العمل في حالة الرغبة لاختصار الكود Sub test1() Dim DataRng As Range, arr As Variant Dim Ct As Long, i As Long, tmp As Boolean Dim ws As Worksheet, dest As Worksheet Dim WSname As String, destName As String '****التحقق من وجود ورقة العمل المرغوب الترحيل منها WSname = InputBox(" : يرجى إدخال اسم الشهر المرغوب ترحيله") If Len(Trim(WSname)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set ws = ThisWorkbook.Sheets(WSname) On Error GoTo 0 If ws Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '****التحقق من وجود ورقة العمل المرغوب الترحيل اليها destName = InputBox(" : يرجى إدخال اسم الشهر المرحل إليه") If Len(Trim(destName)) = 0 Then MsgBox " تم إلغاء الترحيــل", vbExclamation Exit Sub End If On Error Resume Next Set dest = ThisWorkbook.Sheets(destName) On Error GoTo 0 If dest Is Nothing Then MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى" Exit Sub End If '***** نطاق البيانات Set DataRng = ws.Range("B5:B200") tmp = Application.WorksheetFunction.CountA(DataRng) > 0 If Not tmp Then MsgBox WSname & " " & "لا يوجد بيانات للنسخ في شهر", vbExclamation Exit Sub End If '****افراغ البيانات السابقة dest.Range("B5:B200").ClearContents ReDim arr(1 To DataRng.Rows.Count, 1) Ct = 0 For i = 1 To DataRng.Rows.Count If Len(DataRng.Cells(i, 1).Value) > 0 Then Ct = Ct + 1 arr(Ct, 1) = DataRng.Cells(i, 1).Value End If Next i ' لصق البيانات بداية من الصف 5 من ورقة الشهر المختارة If Ct > 0 Then For i = 1 To Ct dest.Range("B5").Offset(i - 1, 0).Value = arr(i, 1) Next i End If MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation End Sub ولنسخها بدون تكرار ستجد الكود داخل الملف المرفق ترحيل.xlsm

جرب هذا المرفق يجب تثبيت واتساب للكمبيوتر وربطه بحساب واتساب الخاص بك أولا ثم فتح الواتس اب قبل الضغط على زر الإرسال ثم الضغط على الزر المرتبط بماكرو الارسال سيتم الارسال لكل من هو مكتوب امامه تاريخ اليوم ولم يتم الارسال له من قبل (خلية تم الرسال فارغة) مع التنبيه على كتابة رقم الموبايل مع مفتاح الدولة ويمكن تشغيل الكود بمجرد فتح هذا الشيت (في خدث فتح الشيت worksheet_open) ولكن الأفضل بعد الضغط على الزر (فربما لم تفتح الواتس اب أو ربما يوجد بيان ناقص في البيانات) بالتوفيق برنامج الصيانة.xlsb

أستاذ Al Shahbandar أين الضغط على الإعجاب ؟!!!! 💙

وعليكم السلام-اهلا بك بالمنتدى , كان عليك استخدام خاصية البحث بالمنتدى-تفضل ملف لاحتساب تكاليف وتسعير طلبية بضاعة مستوردة وهذه ملفات وبرامج أخرى Auto Expense Report.xls Purchases.xls اكسل محاسب الاستيراد.rar