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

السلام عليكم ورحمه الله وبركاته تفضل لعله طلبك فقط النطاق المسمي Data تم تمديده لحل مشكلتك ‏‏‏‏جديد 1.xlsm

Try Sub Test() Dim ws As Worksheet, m As Long, i As Long, ii As Long Application.ScreenUpdating = False Set ws = ActiveSheet: m = 2 With ws .Columns("K:M").Clear .Columns("M").ColumnWidth = 11 With .Range("K1").Resize(, 3) .Value = Array("Group", "Number", "Work Date") .Interior.Color = RGB(146, 205, 220) .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With For i = 2 To 6 If .Cells(i, 2).Value < .Cells(i, 3).Value And IsNumeric(.Cells(i, 2).Value) And IsNumeric(.Cells(i, 2).Value) Then For ii = .Cells(i, 2).Value To .Cells(i, 3).Value .Cells(m, "K").Resize(, 3).Value = Array(.Cells(i, 1).Value, ii, .Cells(i, 4).Value) m = m + 1 Next ii End If Next i End With Application.ScreenUpdating = True End Sub

توكلنا على الله

دي تحط تحتها 600 خط أحمر . هو مشروع جميل وفكرته حلوة بالنسبة لي ، ولكنه سيستغرق وقت وجهد طويل فعلاً ، لذا انصحك بانشاء الجداول بدايةً وباتباع اسلوب محدد وهو :- لا تستخدم أسماء عربية في مسميات الحقول . لا تستعمل المسافات بين الأسماء . لا تستعمل اسماء حقول محجوزة للبرنامج مثل ( Name,Date,To,From ..... إلخ ) لا تستعمل رموز ( #، @،$،& .... إلخ ) في مسميات الحقول . لا تستعمل الأرقام في أسماء حقول الجداول أو تبدأ بها . دي بعض الأساسيات بالنسبة لي اللي لازم أتبعها في تأسيس الجداول ، ثم اعتماد الحقل الرئيسي أو اللي لازم اربط فيه الأمور ببعضها ، وهنا هيكون رقم الكتاب المفتاح الفريد أو الغير مكرر . ابتدي وارفع ملفك ونتابع مع بعض لأنه طبعاً مستحيل يكون كل اللي انت وضحته في جلسة وحدة . بالتوفيق

نعم أخي @Zooro1 . حتى تكون الفكرة واضحة

مشكور اخي وحبيبي Foksh وجزاكم الله خيرا وزادكم علما علي المجهود المقدر والنتيجة الجميلة التي ظهر بها التقرير وهو ما كنت اريده فعلا🌷

مشاركة مع الاساتذة الكرام تفضل أستاذ @TAMER AGOOR محاولتي حسب مافهمت . ووافني بالرد . DDTwoReports.rar

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

استاذ @عبد اللطيف سلوم اضافة لمسة بسيطة جعل ماسج ادخال الباسوورد نجوم (*****) .واخفاء الرقم السري بجداول النظام المخفية تفضل المرفق . رقم سري.rar

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

توضحت الفكرة .. اليك حلين اثنين واختر ما تريده . الأول لو كان الإسم أكبر من 4 مقاطع :- Private Sub comb1_Click() Dim parts() As String parts = Split(txtNm.Value, " ") If UBound(parts) > 3 Then MsgBox "النص أكبر من 4 مقاطع" Exit Sub End If name1 = parts(0) name2 = parts(1) name3 = parts(2) name4 = parts(3) End Sub والثاني تحسباً لو كان الإسم أقل من 4 مقاطع :- Private Sub comb1_Click() Dim parts() As String parts = Split(txtNm.Value, " ") If UBound(parts) > 3 Then MsgBox "النص أكبر من 4 مقاطع" Exit Sub ElseIf UBound(parts) < 3 Then MsgBox "النص أصغر من 4 مقاطع" Exit Sub End If name1 = parts(0) name2 = parts(1) name3 = parts(2) name4 = parts(3) End Sub جرب واخبرني بالنتيجة 😊

مشكوررر اخى خليفة

شكر وتقدير واحترام من اخيك

للعلم اخي الكريم ، التعديل على برنامج جاهز ليلبي حاجتك قد يستغرق وقت أطول من بداية تصميمه من البداية 😅

حالياً لاني متابع من الموبايل ، اكتب لي بشرح وافي ( ولا تبخل بالشرح الواضح ) الفكرة اللي متخيلها للبرنامج من لحظة أول نموذج ..... الخ 😅

ربي يسلمك من كل مكروه أخي @ابو العزايم ،، أعتذر عن التأخير ، وبالنسبة لطلبك ، انظر لهذا التعديلات في التقرير Copy . وأخبرني بالنتيجة Ac Source.accdb

اسف اخي على التاخير في الرد بسبب ظروف العمل وضيق الوقت لدي تفضل جرب هدا حاولت تعديل الاكواد قدر المستطاع للحصول على نفس الشكل المطلوب اتمنى ان يلبي طلبك Book معدل.xls

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل اخى باسسورد الدخول 123 نظام الحسامي للمخازن-123.xlsb

لم تدكر اخي ما هو النطاق المطلوب تفضل جرب هل هدا ما تقصده Sub CopySheet() Dim filePath$, folderName$, Fname$ Dim rCopy As Range, rng As Range Dim lRow As Long, i As Integer Dim wbSource As Workbook Set wbSource = ThisWorkbook Set WS = wbSource.Worksheets("Sheet1") lRow = WS.Range("B" & WS.Rows.Count).End(xlUp).Row Set rCopy = WS.Range("A7:K" & lRow).SpecialCells(xlCellTypeVisible) folderName = "ملفات Excel" Fname = "تقرير النشاط" filePath = ThisWorkbook.path & "\" & folderName On Error Resume Next 'OR 'filePath = "D:" & "\" & folderName If WS.Range("L9:L" & lRow).SpecialCells(xlCellTypeVisible).Count > 1 Then With Application .ScreenUpdating = False .DisplayAlerts = False .CopyObjectsWithCells = False Set newWb = Workbooks.Add: Set SH = newWb.Sheets(1) rCopy.Copy Destination:=SH.Range("A3") LastR = SH.Range("A" & SH.Rows.Count).End(xlUp).Row SH.Range("A7:A" & LastR).RowHeight = 28 For i = 1 To 11 Columns(i).ColumnWidth = WS.Columns(i).ColumnWidth Next i SH.[A5] = 1: SH.Range("A5:A" & SH.Cells(Rows.Count, 2).End(3).Row).DataSeries , xlLinear 'Columns(1).Delete If Dir(filePath, vbDirectory) = "" Then MkDir filePath newWb.SaveAs fileName:=filePath & "\" & Fname & ".xlsx", FileFormat:=51 newWb.Close .CopyObjectsWithCells = True .DisplayAlerts = True .ScreenUpdating = True End With sMsg = "Excel" & " " & "تم حفظ التقرير بنجاح في مجلد " & "ملفات" MsgBox sMsg, vbExclamation, " من تاريخ: " & " " & WS.[D4] & " " & "إلى تاريخ:" & " " & WS.[F4] Else MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء" End If End Sub فلترة وحفظ.xlsm

تقصد ان هدا الشكل لا يناسبك هل قمت بتجربة هدا Sub test() Dim lCol As Long, MyRng As Range Set desWS = ActiveSheet: Set ws = Sheet2 If Len(desWS.[CA328].Value) = 0 Then Exit Sub ws.Cells.Clear For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i Set MyRng = desWS.[BW330:CK372] Application.ScreenUpdating = False MyRng.Copy If ws.[D9] = "" Then MyRng.Copy With ws.[c5] .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With Else lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column + 5 MyRng.Copy With ws.Cells(5, lCol) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats End With End If Application.CutCopyMode = False Application.ScreenUpdating = True Next i End Sub 2024-04-11 الفواتير من 2024-04-05 الى.pdf

ادا كنت قد فهمت طلبك بشكل صحيح يمكنك الحصول على دالك بتفعيل هدا السطر حيث يتم فلترة البيانات بشرط عمود المفتاح ما بين التواريخ الموجودة في الخلايا D4 و F4 '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) اما بالنسبة ل كود عمل نسخة احتياطية كل عشر دقائق ضع الكود التالي في module Sub SaveBackup() Dim filePath$,folderName$,copyName$ Dim ThisBook As Workbook : Set ThisBook = ThisWorkbook 'مسارالحفظ ' filePath = "D:": 'اسم مجلد الحفظ folderName = "BACKUPS" With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next copyName = filePath & "\" & folderName & " " & _ Format(Now, "dd-mmmm-yyyy") 'انشاء مجلد الحفظ في حالة عدم العثور عليه If Dir(copyName, vbDirectory) = "" Then MkDir copyName ThisBook.SaveCopyAs copyName & "\" & ThisBook.Name & " " & _ Format(Now, "dd-mmmm-yyyy-HH-MM-SS") & ".xlsm" ' قم بتعديل وقت الحفظ بما يناسبك Application.OnTime Now + TimeValue("00:10:00"), "SaveBackup" 'حفظ المصنف الرئيسي ' ActiveWorkbook.Save .DisplayAlerts = True .ScreenUpdating = True End With End Sub وفي حدث Private Sub Workbook_Open Private Sub Workbook_Open() Call SaveBackup End Sub تفضل جرب المرفق التالي بالتوفيق فلترة وحفظ.xlsm

جرب هدا Private Sub TextBox1_Change() Set WS = Sheets("Sheet1") On Error Resume Next If WS.TextBox1.Text = Empty Then WS.[A8:L8].AutoFilter lr = WS.Cells(WS.Rows.Count, "L").End(xlUp).Row Clé = "*" & Replace(WS.TextBox1.Text, " ", "*") & "*" If WS.TextBox1.Text <> "" Then Set rng = WS.Range("A8:L" & lr) '****المفتاح***** rng.AutoFilter field:=12, Criteria1:=Clé '******* اظافة شرط بين تاريخين rng.AutoFilter field:=3, _ Criteria1:=">=" & CDbl(WS.[D4]), Operator:=xlAnd, _ Criteria2:="<=" & CDbl(WS.[F4]) Else WS.[A8:L8].AutoFilter End If End Sub Sub test() Dim desWS As Worksheet: Set desWS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = printing Application.ScreenUpdating = False If Sheets("Sheet1").TextBox1.Text = "" Then Exit Sub rng = Application.WorksheetFunction.Subtotal(3, desWS.Range("L9:L10000")) If rng = 0 Then: MsgBox "لا توجد بيانات للحفظ", vbInformation, "تم إلغاء الإجراء": Exit Sub Set a = desWS.Range("A8", desWS.Range("A" & desWS.Rows.Count).End(xlUp)) ' For r = 1 To 11 لغاية عمود الملاحظات For r = 1 To 12 'مفتاح ' لغاية عمود Set a = Union(a, Intersect(a.EntireRow, a.Columns(r))) Next r Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير التقرير بصيغة", vbYesNo, dest.Name) If Msg <> vbYes Then Exit Sub dest.Range("A3:L" & dest.Rows.Count).Clear a.Copy Destination:=dest.Range("A6") 'حفظ PDF Save_As_PDF2 On Error Resume Next desWS.AutoFilter = False Sheets("Sheet1").TextBox1.Text = "" Application.ScreenUpdating = True End Sub فلترة وحفظ PDF +EXCEL V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا (تم اظافة ورقة جديدة مخفية على الملف باسم PDF لتجميع الفواتير اظن ان مدى بيانات الفاتورة غير مطابق لما كتبته هنا ادا لم اكن مخطئ Sub svPDF() Dim MyRng As Range, r As Long, i As Integer, LR As Long Dim fRow, Cpt As Range, FndRng As Range, myValue As String Dim sFile As String, FolderName As String Set desWS = Sheet79: Set WS = PDF Set MyRng = desWS.[BW330:CK372] minDate = Format(desWS.[DC330], "yyyy-mm-dd"): maxDate = Format(desWS.[CV330], "yyyy-mm-dd") 'قم بتحديد مسار حفظ الملف بما يناسبك 'Path = "C:" ' المسار الافتراضي للملف الرئيسي Path = Application.ActiveWorkbook.Path 'اسم الملف المستخرج sFile = minDate & " " & "الفواتير من" & " " & maxDate & " " & "الى" ' اسم مجلد الحفظ FolderName = "raed": 'شرط فواصل الصفحات myValue = "اجمالى الواصل" If Len(desWS.[CA328].Value) = 0 Then Exit Sub Application.ScreenUpdating = False On Error Resume Next WS.Visible = xlSheetVisible: WS.Cells.Clear For i = desWS.[CA328] To desWS.[CE328]: desWS.[BU331].Value = i With ActiveWorkbook sPath = Path & Application.PathSeparator & FolderName & Application.PathSeparator If Len(Dir(sPath, vbDirectory)) = 0 Then End If MkDir sPath MyRng.Copy LR = WS.Cells(Rows.Count, "j").End(xlUp).Row + 4 With WS.Range("A" & LR) .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With End With Next i With WS fRow = .Range("a:o").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set FndRng = .Range("j10:j" & fRow) Set Cpt = FndRng.Find(What:=myValue, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not Cpt Is Nothing Then: Linge = Cpt.Address Do If Not Cpt Is Nothing Then: Cpt.Offset(2).PageBreak = xlPageBreakManual Set Cpt = FndRng.FindNext(Cpt) If Cpt Is Nothing Then: Exit Do If Cpt.Address = Linge Then: Exit Do Loop WS.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 End With WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & Application.PathSeparator & sFile & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.Visible = xlSheetVeryHidden On Error GoTo 0 Application.ScreenUpdating = True End Sub Book2.xls

وعليكم السلام ورحمة الله وبركاته تفضل أخي ميزان مراجعة 2023.xlsx

جرب هل هدا ما تقصده إنتهاء الرحصة.xlsm

بسم الله الرحمن الرحيم لاحظت في الفترة الأخيرة كثرة الأسئلة عن موضوع نسيان كلمات مرور ملفات الإكسل أو بعض ورقات العمل بالملف فأحببت أن أشارك إخوتي وأحبّتي أعضاء ومشرفي وخبراء منتدانا الرائع هذه الإضافة MasNoPass لفك حماية أوراق العمل في ملفات الإكسل وتعمدت تسهيل عملها &&&&&&&&&&& فقط تحتاج لإضافة الوظيفة الإضافية: 1 في ويندوز xp نسخ المرفق إلى المسار التالي C:\Documents and Settings\***\Application Data\Microsoft\AddIns حيث أن C هو قرص النظام و *** هو اسم المستخدم 2 في ويندوز 7 نسخ المرفق إلى المسار التالي C:\Users\***\AppData\Roaming\Microsoft\AddIns حيث أن C هو قرص النظام و *** هو اسم المستخدم ****************** بالنسبة لمستخدمي إكسل 2003 من خلال: فتح برنامج الإكسل والضغط على قائمة أدوات tools ===> وظائف إضافية Addins ===> ثم اختر MasNoPass ثم موافق ok وبالنسبة لمستخدمي إكسل 2007 يتم ذلك من خلال : فتح برنامج الإكسل والضغط على زر الأوفيس ثم خيارات إكسل Excel options ثم اختيار وظائف إضافية Addins من الجانب الأيمن/الأيسر ثم اذهب go ثم اختيار MasNoPass ثم موافق ok وبالنسبة لمستخدمي إكسل 2010 وما بعدها يتم ذلك من خلال : فتح برنامج الإكسل والضغط على قائمة ملف file ثم خيارات إكسل Excel options ثم اختيار وظائف إضافية Add-ins من الجانب الأيمن/الأيسر ثم اذهب go ثم اختيار MasNoPass ثم موافق ok /////////////////// طريقة العمل:- بعد تسجيل الوظيفة الإضافية تجد ظهور قائمة جديدة باسم (فك الحماية) وتحتاج فقط إلى فتح الملف المحمي ثم الضغط على قائمة فك الحماية واختيار (إزالة كلمة المرور) بعدها سيتم البدء في عدّ المحاولات والوقت المنقضي في إجراء العملية بعدها تظهر رسالة تفيد أنه تم إزالة كلمة المرور عن الملف وبعد الضغط على الرسالة ستجد الملف مفكوك بين يديك $$$$$$$$$$$$$$$$ و أذكّر نفسي وإياكم بأن الصحابة عليهم رضوان الله كان الواحد منهم إذا أراد أن يدعو لنفسه دعا لأخيه فيقول له الملك آمين ولك مثلها فلا ينقصني سوى دعائكم وأخيرا أذكر بخطورة الموقف وأرجو عدم استعمالها فيما حرّم الله وعند النقل يجب ذكر المصدر منتديات أوفيسنا اللهم قد بلّغت ... اللهم فاشهد أخوكم محمد صالح فيديو لشرح كيفية استعمال الأداة ولا ينقصني سوى دعاؤكم ينصح بالاشتراك في القناة وتفعيل جرس التنبيه ليصلكم كل جديد ومفيد وقت صدوره MasNoPass.rar New_MasNoPass.rar

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

السلام عليكم ورحمة الله وبركاته في مايكروسوفت اكسس لدي جدول اسمه "المواقف" يحتوي على حقل اسمه[رقم الموقف ] نوع ترقيم تلقائي وهو مفتاح اساسي وحقل [ تاريخ الموقف ]وحقل [اليوم ] يرتبط بهذا الجدول اربعة جداول بعلاقة ون تو ميني هي ١-جدول "اجتماعات العاملين "وهذا الجدول مرتبط به جدول اسمه "حضور الاجتماعات " وانشأت منهما استعلام حتى يقوم بحساب عدد المشاركين في كل اجتماع ٢-وجدول "الدورات" وهذا مرتبط به جدول اسمه "المشاركين في الدورات " وانشأت منهما استعلام يحسب عدد المشاركين في كل دورة ٣- وجدول "النزول الميداني ٤-وجدول" المادة التي تم توزيعها" اريد ان يكون هناك نموذج بحث بين تاريخين لطباعة تقرير يومي واسبوعي وشهري وسنوي عندما ادخل تاريخ محدد باليوم مثلا يقوم بعرض التقرير وفي اعمال ذلك اليوم فقط لاجتماعات ذلك اليوم ودورات ذلك اليوم ونزول ذلك اليوم و وتوزيع مادة ذلك اليوم وكذلك عندما اقوم بادخال تاريخ اليوم الى بعد سبعة يقوم بعرض ماتم في تلك السبعة الايام وهكذا بالنسبة للشهري والسنوي