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

اعرض الملف استبدال أسماء كل الملفات فى مجلد بحثت عنه ولم اجده ـ على الرغم اني اذكر اضافته سابقا فاضيفه الان لمن يحتاج مثل هذا الكود 1- استخدم الكود السابق نشره لتوثيق كافة اسماء الملفات فى مجلد مكتبة الموقع - تطبيق لتوثيق قائمة بالمجلدات و الملفات و خصائصها - مفيد جداً او كتب اسماء الملفات الحالية الموجودة فى المجلد المستهدف مباشرة فى العمود B 2 - ثم اكتب فى العمود D اسماء الملفات الجديدة 3- شغل الكود لاستبدال اسماء الملفات ، و اختار المجلد المستهدف Sub RenameMultipleFiles() ' add old file name to column B , and new File name to Col D With Application.FileDialog(msoFileDialogFolderPicker) .AllowMultiSelect = False If .Show = -1 Then selectDirectory = .SelectedItems(1) dFileList = Dir(selectDirectory & Application.PathSeparator & "*") Do Until dFileList = "" curRow = 0 On Error Resume Next 'read old file name from column B curRow = Application.Match(dFileList, Range("B:B"), 0) If curRow > 0 Then 'cganeg to new file name from column D Name selectDirectory & Application.PathSeparator & dFileList As _ selectDirectory & Application.PathSeparator & Cells(curRow, "D").Value End If dFileList = Dir Loop End If End With End Sub صاحب الملف محمد طاهر عرفه تمت الاضافه 06 يول, 2024 الاقسام قسم الإكسيل  

Private Sub PDFConvertor_Click() Dim f As Worksheet: Set f = Sheets("Sheet5") Dim fname As String, filePath As String, folderName As String Dim sMsg As String, xname As String fname = f.[E1] folderName = "PDF ملفات" filePath = ThisWorkbook.Path & "\" & folderName xname = " من " & Format(f.[b1], "dd-mm-yyyy") & " " & _ "إلى " & " " & Format(f.[b2], "dd-mm-yyyy") Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير بصيغة", vbYesNo, fname) If Msg <> vbYes Then Exit Sub 'Call Main If Dir(filePath, vbDirectory) = "" Then MkDir filePath Set Rng = f.Range("A1").CurrentRegion f.PageSetup.PrintArea = Rng.Address f.ExportAsFixedFormat Type:=xlTypePDF, _ FileName:=filePath & "\" & fname & xname & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, _ IgnorePrintAreas:=False, OpenAfterPublish:=False f.PageSetup.PrintArea = "" Application.ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح " & vbCrLf & vbCrLf & xname, vbInformation, "PDF" End Sub '********************************** Private Sub Save_Excel_Click() Dim sh As Worksheet, NewWb As Workbook Dim folderName As Variant, FileName As String, fname As String Set sh = ThisWorkbook.Sheets("Sheet5") fname = sh.[E1] folderName = "ملفات Excel" filePath = ThisWorkbook.Path & "\" & folderName With Application .DisplayAlerts = False .ScreenUpdating = False sh.Copy Set NewWb = ActiveWorkbook: Set n = NewWb.Sheets(1) n.Name = fname n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete If Dir(filePath, vbDirectory) = "" Then MkDir filePath NewWb.SaveAs FileName:=filePath & "\" & fname & ".xlsx", FileFormat:=51 NewWb.Close False Set NewWb = Nothing .DisplayAlerts = True .ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح ", vbInformation, "Excel" End With End Sub '************************************************** Private Sub WordView_Click() Dim lr&, tmp As Word.Document, n As Word.Application Dim WS As Worksheet: Set WS = Sheets("Sheet5") lr = WS.Range("A:A").Find("*", _ searchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set n = CreateObject("word.application") n.Visible = True: Const Cnt As Long = 1 xname = "Word ملفات" Patch = ThisWorkbook.Path & "\" & xname fname = WS.[E1] xdate = " من " & Format(WS.[b1], "dd-mm-yyyy") & " " & _ "إلى " & " " & Format(WS.[b2], "dd-mm-yyyy") Application.ScreenUpdating = False With WS.Range("A" & Cnt & ":H" & lr).Copy Set tmp = n.Documents.Add n.Selection.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False Application.CutCopyMode = False n.ActiveDocument.PageSetup.Orientation = wdOrientLandscape n.ActiveDocument.PageSetup.PaperSize = WdPaperSize.wdPaperA3 If Dir(Patch, vbDirectory) = "" Then MkDir Patch tmp.SaveAs Patch & "\" & fname & xdate & ".docx" tmp.Close Set tmp = Nothing n.Quit Set n = Nothing End With Application.ScreenUpdating = True MsgBox " تم حفظ الملف بنجاح " & _ vbCrLf & vbCrLf & xdate, vbInformation, "Word" End Sub كرت الصنف 2024 V2.xlsm

اتفضل هذا المطلوب 2.rar

من المفروض ان تقوم بتصميم ملفك بالشكل المطلوب وارفاقه بدل رفع الصورة لهدا ساقتصر انا كدالك على ارفاق صورة بعد اظافة الجدول على عينة من البيانات وتنسيقه استخدم ما يلي Private Sub Image1_Click() Set f2 = Sheets("Sheet5") Application.ScreenUpdating = False f2.[A4:H10000].ClearContents r1 = TextBox1.Value: r2 = TextBox2.Value: r3 = TextBox3.Value: r4 = ComboBox1.Value: r5 = ComboBox2.Value hrd1 = Array("من تاريخ :", r1, " ", "اسم المخزن :", r4, "رصيداول مدة :") hrd2 = Array("الى تاريخ :", r2, " ", "اسم الصنف :", r5, r3) Titres = Array("رقم المستند", "التاريخ", "نوع الحركة", "اسم المخزن", "اسم الصنف", "شراء", "بيع", "الرصيد") f2.[A1].Resize(1, 6) = hrd1 f2.[A2].Resize(1, 6) = hrd2 f2.[A3].Resize(1, 8) = Titres a = Me.ListBox1.List f2.[A4].Resize(UBound(a) + 1, UBound(a, 2) + 1) = a Unload Me Set Rng = f2.Range("A1").CurrentRegion f2.PageSetup.PrintArea = Rng.Address f2.PrintPreview End Sub

بعد الاضافة الرائعة من استاذ @Foksh❤️ هل يجب اضافة جدول خاص للاستعاده الوضع السابق بعد التحريك او الاحسن تخليها قيم داخل الكود برنامج للتحكم بتحريك الازرار وتخصيص بالمواس وتخصيص تغير نمط الفورم باللون بس في مشكلة في فورم الاغلاق عند الفتح (نفس الفورم)على كل فورم غيرة بينة التصميم 😇 للفورم موضح بالفيديو ؟! هل يوجد حل ❤️🌹 كيف حفظ القيمة داخل الدالة ورجوع لها (تاخذ القيمة متغيره من الفورم وتحفظ في Function ?! "=============================(طريقة اضافة رمز Mouse ) for .Cur And .ani = (Animation ) 1-ببرنامج تحويل الصور حول من امتداد (.Cur) To (.Png) 2-نسخ الى نفس الملف (والملف واحد) الكل نفس التسمية (.Cur) And (.Png) And (.ani) اتمنى لكم تجربة ممتعة Move And Drops.part01.rar Move And Drops.part02.rar Move And Drops.part03.rar Move And Drops.part04.rar Move And Drops.part05.rar Move And Drops.part06.rar

أحسنت ياصديقي بحار الاكسس لو كنت أمامي لقبلت رأسك وسلمت يداك وشكر جزيلا لوقتك الثمين

هذا المطلوب؟ 2.rar

السلام عليكم ورحمة الله وبركاته هذا موضوع اخر اخي محمود

لا شكر على واجب اخي الكريم @شريف كونكت .. في أقرب فرصة إن شاء الله اليوم نوصل لحل في التقرير عند وضع الطباعة 🤗

عندنا مثل يقول : هذه ما تحتاج مطوع معناه ان هذه المسألة لا تحتاج الى قاضي اومفتي يبين لنا فشرحك هذا هو شرح للمستخدم كيف يستخدم البرنامج وليس لمن يريد ان يفهم كيف تمت هذه العمليات فقط الحقلين المخفيين اجبت بنصف اجابة .. لذا لزم ان نوضح كيف تتم هذه العمليات : اولا : تعيين الفصل الدراسي الحالي : العمل يتم بين جدول اسماء الطلاب وجدول ادخال الدرجات .. فعملنا استعلام الحاق يقوم بالحاق اسماء جميع الطلاب و الصف والفصل ورقم الجلوس + الفصل الدراسي الحالي .. والحاقه في جدول ادخال الدرجات .... انظر الى الكود في حدث النقر على زر الاعداد .................................. - عملنا ثلاث نماذج رئيسي وفرعيين ... الرئيسي غير منضم ويشتمل على حقول : الفصل الدراسي والصف والمادة ويشتمل على زرين كل واحد من الزرين يعرض نموذج فرعي مختلف عن الآخر . - النموذجين الفرعيين مصدرهما واحد وهو جدول الدرجات ولكن عن طريق استعلام من اجل التصفية حسب الفصل الدراسي والمادة والصف - النموذج الفرعي الأول الخاص بادخال مادة واحدة بعد التصفية .. ويحتوي على حقل واحد لدرجة المادة ويتغير مصدر هذا الحقل ( حقل المادة في الجدول) عند النقر على زر اعداد .. باستخدام كود بناء على مربع المادة في النموذج الرئيس . انظر الكود في حدث النقر على زر اعداد النموذج الفرعي الثاني وبعد النقر على زر عرض : يعرض جميع حقول الجدول ويتم فيه فقط التصفية . .................................................. بالنسبة للحقلين المخفيين فأنت ذكرت انهما لاختيار الصفوف العليا والدنيا والمواد المخصصة للعليا والدنيا والمشتركة بينهما. وهذا الشرح بحاجة الى شيء من التفصيل : - جدول الصف يوجد حقل لتمييز الصفوف الدنيا من العليا بالرقمين 1 ، 2 - في جدول المواد يوجد حقل (عمود) يوضح ان كانت المادة للصفوف الدنيا ام للصفوف العليا وتم تعيين الرقمين ، 1 ،2 وحيث ان الصفوف الدنيا تشترك مع العليا في اكثر من مادة لذا وجب تمييز المادة المشتركة برقم يخصها فوضعنا رقم 3 لذلك . هنا يأتي دور حقل الصف فعند اختيار صف من الصفوف الدنيا يضع في الحقل المخفي الأول رقم 1 وفي الثاني رقم 3 وعند اختيار الصفوف العليا يضع في الحقل المخفي الأول رقم 2 وفي الثاني رقم 3 ... لاحظ ان رقم 3 ثابت في الحقل المخفي الثاني والسبب لأنه مشترك بين المرحلتين ... انظر الى الكود المسؤول في حدث بعد التحديث لحقل الصف .............................. نأتي للاستعلام مصدر صف مربع التحرير المادة .. ونضع فيه معيارا في الحقل المخصص لا يعرض من خلاله الا المواد الخاصة بالمرحلة الدنيا او العليا .. حسب قيمة الحقلين المخفيين ونفصل بينهما بـــ OR الشرح يطول ولكن هذا المختصر المفيد آمل ان ترجع الى المثال وتتبع خطوات الشرح خاصة : الحاق الطلاب والفصل الدراسي .. ( مثلا امسح جميع بيانات جدول الدرجات .. اغلق الجدول .. افتح نموذج اعداد الفصل الدراسي وقم بالاعداد .. ثم عد مرة اخرى الى جدول الدرجات واطلع على النتيجة ) جميع مربعات التحرير في نموذج الدرجات الرئيسي .. افتح مصدر بيانات الصف الذي هو استعلام داخلي واطلع على المعايير من اجل ترسخ لديك الطريقة الأحداث ( الأكواد) في نموذج الدرجات الرئيسي وادرسها جيدا اذا صعب عليك فهم اي شيء فبادر واطرح استفسارك هنا ، نتوقع منك ذلك .. فمن اجل هذا تواجدنا في المنتدى

لم اقم بالتجربة على التقارير فعلاً كونك لم تأتي بتحديد التقارير ، ولكن جرب انت واخبرنا بالنتيجة ، وأنا سأقوم بالتجربة غداً أيضاً ، وإن لم يتم الامر على التقارير سنقوم باللازم.

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub UserForm_Initialize() Set f = Sheets("التقرير") Set Rng = f.Range("A3:j" & f.[A65000].End(xlUp).Row) wsData = Rng.Value For i = LBound(wsData) To UBound(wsData): wsData(i, 5) = Format(wsData(i, 5), "0.00"): Next i For i = 1 To UBound(wsData): wsData(i, 6) = Format(wsData(i, 6), "0.00"): Next i 'Code............ '''''''''''' End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("Sheet1") End Property Sub Sort_Category() Dim OneRng As Range Dim lr As Long lr = F.Cells(Rows.Count, "E").End(xlUp).Row Set OneRng = F.Range("A2:L" & lr) With OneRng .Sort Key1:=.Columns(5), Order1:=xlDescending, Header:=xlNo End With End Sub '***************************** Sub Filter_and_create_Sheets() Application.DisplayAlerts = False Application.ScreenUpdating = False F.[w1] = F.[E1] RngA = F.[A1].CurrentRegion.Rows.Count RngB = F.[A1].CurrentRegion.Columns.Count F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy, _ CopyToRange:=F.[w1], Unique:=True For Each c In F.Range("W2:W" & F.[W65000].End(xlUp).Row) F.[W2] = c.Value On Error Resume Next Sheets(CStr(c.Value)).Delete On Error GoTo 0 Sheets.Add After:=Sheets(Sheets.Count) Set n = ActiveSheet n.Name = CStr(c.Value) n.DisplayRightToLeft = True F.[A1].Resize(RngA, RngB).AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=F.[W1:W2], CopyToRange:=[A1] For r = 1 To 12 n.Cells.EntireRow.AutoFit n.Columns(r).ColumnWidth = F.Columns(r).ColumnWidth Application.ErrorCheckingOptions.NumberAsText = False Next Next c F.Activate End Sub تقرير صف أول 2025.xlsm

اعمل تجميع في التقرير .. تجد الارفام متسلسلة من جديد .... او ادرج مرفق للتعديل عليه