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

العفو اخي تفضل تم تعديل الكود واظافة انشاء مجلد الحفظ تلقائيا في نفس مسار الملف عند التحقق من عدم وجوده بالتوفيق.... Sub Copy_invoices_2() Dim j&, I&, WSdest As Workbook Dim MyData As Workbook: Set MyData = ThisWorkbook Dim Customer As String, Chemin As String, LastRow As Long Dim MyRang As Range, LastRng As Long, DesTRng As Long Dim MyFolder, Save_Folder, MyPath As String Customer = MyData.Sheets(1).[b2] On Error Resume Next If IsEmpty([b2]) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub 'اسم مجلد الحفظ قم بتعديله بما يناسبك MyFolder = "السجل" MyPath = Application.ActiveWorkbook.Path If IsEmpty(MyFolder) Then Exit Sub If IsEmpty(Customer) Then Exit Sub MkDir MyPath & "\" & MyFolder Save_Folder = MyPath & "\" & MyFolder & "\" & Customer Chemin = Save_Folder & ".xlsx" LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow) Application.ScreenUpdating = False Application.DisplayAlerts = False If Len(Dir(Chemin)) = 0 Then Set WSdest = Workbooks.Add MyRang.Copy With WSdest.Sheets(1).[A1] .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next j End With [A1].Select WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51 WSdest.Close Else Set WSdest = Workbooks.Open(Chemin) LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1 MyRang.Copy With WSdest .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer End With For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(I, 1) = Empty And WSdest.Sheets(1).Cells(I, 5) = "0" Then Rows(I).Delete Next [A1].Select WSdest.SaveAs Save_Folder & ".xlsx", FileFormat:=51 WSdest.Close End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الديباجة 4.xlsb

لو بحثت لوجدت الكثير ربما يفيك هذا الرابط Searched for 'طباعة الكل pdf' in موضوعات (officena.net) بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته Dim f, WsData, MyRng(), Tbl() Private Sub UserForm_Initialize() Set f = Sheets("Follow up") Set WsData = f.Range("A5:I" & f.[A650000].End(xlUp).Row) MyRng = WsData.Value For i = 1 To UBound(MyRng) n = n + 1: ReDim Preserve Tbl(1 To UBound(MyRng, 2), 1 To n) For k = 1 To UBound(MyRng, 2): Tbl(k, n) = MyRng(i, k): Next k Me.ComboChoixColFiltre.List = Application.Transpose(WsData.Offset(-1).Resize(1)) Me.ComboChoixColFiltre.ListIndex = 0 Me.LabelColFiltre.Caption = "فلترة ب:" & Me.ComboChoixColFiltre ListBox1.ColumnWidths = "120;120;130;120;130;120;120;120" Next i ' لإظهار البيانات على الليست بوكس قم بتفعيل السطر التالي 'Me.ListBox1.Column = Tbl End Sub '********************************************** Private Sub CommandButton1_Click() Dim Tbl() If Recherche.Value = Empty Or ComboChoixColFiltre.Value = Empty Then MsgBox "المرجوا ادخال معيار البحث", vbInformation + vbMsgBoxRight + vbMagBoxRt1Reading, "تعليمات" Exit Sub End If colRecherche = Me.ComboChoixColFiltre.ListIndex + 1 clé = "*" & Me.Recherche & "*": n = 0 For i = 1 To UBound(MyRng) If MyRng(i, colRecherche) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MyRng, 2), 1 To n) For k = 1 To UBound(MyRng, 2): Tbl(k, n) = MyRng(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear End Sub الإصدار أوفيسنا 2.xlsm

السلام عليكم معكم السيد مناد سفيان اليكم برنامج برنامج مجانى واحترافى فى إدارة شؤون الموظفين مفتوح المصدر وقابل للتعديل اليكم رابط تحميل البرنامج نظرا لحجمه الكبير لم استطيع ارفاقه في المنتدى https://www.mediafire.com/file/emkmhxinkbrv3b4/أحدث+برنامج+مجانى+واحترافى++فى+إدارة+شؤون+الموظفين+مفتوح+المصدر+وقابل+للتعديل++.accdb/file

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

تفضل هذا التعديل انشئ موديول جديد و الصق به الشفرة التالية و استخدمها كيفما شئت ' المجموع للشخص الواحد لسنة محددة Public Function OneYears(SetID As Integer, SetYear As Integer) Dim SetCol As Variant, i As Integer SetCol = Null For i = 1 To 12 SetCol = "[" & MonthToNo(i) & "-" & SetYear & "]" OneYears = OneYears + Nz(DSum(SetCol, "[Year_" & SetYear & "]", "[ID]=" & SetID), 0) Next i End Function ' المجموع لجميع الأشخاص و جميع السنوات Public Function AllYears() Dim SetCol As Variant, i As Integer, x As Integer, SetYear As Integer SetCol = Null For x = 2023 To 2025 For i = 1 To 12 SetCol = "[" & MonthToNo(i) & "-" & x & "]" AllYears = AllYears + Nz(DSum(SetCol, "[Year_" & x & "]"), 0) Next i Next x End Function Public Function MonthToNo(SetMonth As Variant) Select Case SetMonth Case Is = 1: MonthToNo = "Jan" Case Is = 2: MonthToNo = "Feb" Case Is = 3: MonthToNo = "Mar" Case Is = 4: MonthToNo = "Apr" Case Is = 5: MonthToNo = "May" Case Is = 6: MonthToNo = "Jun" Case Is = 7: MonthToNo = "Jul" Case Is = 8: MonthToNo = "Aug" Case Is = 9: MonthToNo = "Sep" Case Is = 10: MonthToNo = "Oct" Case Is = 11: MonthToNo = "Nov" Case Is = 12: MonthToNo = "Dec" End Select End Function مرفق الملف بعد التعديل Fam.mdb

هل هذا ما تقصده 🙂 Time +-.accdb

فقط توضيح لهذه العبارة .. أحسست أنها أعطت معنى غير الذي أريده 😅🖐🏼️ طبعا يمكن إضافة متغيرات أخرى من أي نوع بيانات قبل المتغير ذي البادئة ParamArray .. ولكن لا يمكن استخدام البادئات ByVal, ByRef, Optional قبلها ( فقط تكتب اسم المتغير ونوعه ). لذلك يمكنك إضافة المتغير أو المعامل btOptionDialog ولكن لا يمكن جعله Optional .

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

تفضل اخي الكريم ASD.accdb

رحمه الله و أسكنه فسيح جناته

وهذا مثال آخر بشكل مختلف dof3a1.accdb

تفضل اخي الكريم ، مرفق مع التعديلات ، وانت عدل على مزاجك dof3a.accdb

البقاء لله وحده ربنا يرحمه ويغفر له ويسكنه فسيح جناته ويلهم أهله وذويه الصبر والسلوان وانا لله وانا اليه راجعون

تفضل اخي @عمر الجزاوى Sub Copy_invoices() Dim j&, I&, WSdest As Workbook Dim MyData As Workbook: Set MyData = ThisWorkbook Dim Customer As String, Chemin As String, LastRow As Long Dim MyRang As Range, LastRng As Long, DesTRng As Long Customer = MyData.Sheets(1).[b2] Chemin = ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx" LastRow = MyData.Sheets(1).Cells(MyData.Sheets(1).Rows.Count, 1).End(xlUp).Row Set MyRang = MyData.Sheets(1).Range("A1:F" & LastRow) Application.ScreenUpdating = False Application.DisplayAlerts = False If IsEmpty(Customer) Then X = MsgBox("إسم العميل غير موجود ", vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "إنتباه"): Exit Sub If Len(Dir(Chemin)) = 0 Then Set WSdest = Workbooks.Add MyRang.Copy With WSdest.Sheets(1).[A1] .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats .PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer For j = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next j End With [A1].Select WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51 WSdest.Close Else Set WSdest = Workbooks.Open(Chemin) LastRng = WSdest.Sheets(1).Cells(WSdest.Sheets(1).Rows.Count, 1).End(xlUp).Row If WSdest.Sheets(1).[b2] <> "" Then DesTRng = LastRng + 3 Else DesTRng = LastRng + 1 MyRang.Copy With WSdest .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteFormats .Sheets(1).Cells(DesTRng, 1).PasteSpecial Paste:=xlPasteColumnWidths Sheets(1).DisplayRightToLeft = True Sheets(1).Name = Customer End With For I = WSdest.Sheets(1).Cells(Rows.Count, 5).End(xlUp).Row To 7 Step -1 If WSdest.Sheets(1).Cells(j, 1) = "" And _ WSdest.Sheets(1).Cells(j, 5) = "0" Then Rows(j).Delete Next [A1].Select WSdest.SaveAs ThisWorkbook.Path & "\السجل\" & Customer & ".xlsx", FileFormat:=51 WSdest.Close End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الحفظ 2.rar

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

وعليكم السلام ورحمة الله جرب الكود التالى Dim ws As Worksheet: Set ws = Sheets(1) Dim sh As Worksheet: Set sh = Sheets(2) sh.Range("A5:N1000") = "" k = 5 lr = ws.Range("A" & Rows.Count).End(xlUp).Row For i = 3 To lr Dim columns(1 To 3) As Variant columns(1) = "J" columns(2) = "L" columns(3) = "N" For c = 1 To 3 Dim column As String column = columns(c) If ws.Range(column & i) >= sh.[D2] And _ ws.Range(column & i) <= sh.[G2] Then For j = 2 To 20 sh.Cells(k, j) = ws.Cells(i, j) Next k = k + 1 End If Next c Next i

ما شاء الله عليكم تعمقتم في الموضوع وخضتم وتشعبتم في بحور المكتبات 😄🖐🏼️ أما أنا أعود بكم للموضوع الأصلي لأنه خطرت لي فكرة فما أردت لها أن تضيع في زحام الأفكار 😁👌🏼 الفكرة سلمكم الله هي أن تتيح للمستخدم كتابة أنواع الملفات في معامل الدالة على شكل مصفوفة هكذا ("jpg", "png", "pdf", "rar") ومن ثم يجمعها الكود بالشكل الصحيح ليتم استخدامها في الكود حسب الصياغة الصحيحة وإضافة النجمة لها * .. هكذا (jpg, *.png, *.pdf, *.rar.*) ولعمل ذلك استعنت ب ChatGPT لكتابة الكود التالي مع الكثير من التعديلات لإيصال الفكرة لكم .. 🙂 Function FilesTypes(ParamArray Types() As Variant) As String Dim combinedTypes As String Dim i As Integer ' Initialize the combined string combinedTypes = "" ' Loop through the array items and concatenate with the delimiter For i = LBound(Types) To UBound(Types) combinedTypes = combinedTypes & "*." & Types(i) & ", " Next i ' Remove the last "," If Len(combinedTypes) > 0 Then combinedTypes = Left(Trim(combinedTypes), Len(Trim(combinedTypes)) - 1) End If FilesTypes = IIf(Len(combinedTypes) > 0, combinedTypes, "*.*") End Function Sub testing() Debug.Print FilesTypes("jpg", "png", "pdf", "rar") 'Result = *.jpg, *.png, *.pdf, *.rar Debug.Print FilesTypes() 'Result = *.* End Sub ملاحظة مهمة : طبعا حسب إفادة موقع مايكروسوفت المعامل من نوع ParamArray يجب أن يكون في آخر المعاملات في الدالة وهو إختياري في جميع الأحوال ويمكن تركه فارغا .. ولا يصلح أن يتم استخدامه مع المعاملات من نوع ByVal, ByRef, or Optional . لذلك تركت لك مسألة التعامل مع المعامل btOptionDialog الذي في كودك الأصلي لتجد له حلا 😅🖐🏼️ مرجع : https://learn.microsoft.com/ar-sa/office/vba/language/reference/user-interface-help/function-statement

طيب فى موضوع هنا ممكن يكون مفيد و بصراحة مش فاضى اشوف الفيديو الان بس حبيت اضع الرد اثراء للموضوع

وعليكم السلام ورحمة الله تعالى وبركاته هناك حل اخر ممكن ايضا جعل الكود بهده الطريقة Sub Filter_Class2() Dim WSdest As Worksheet: Set WSdest = Sheets("TI3DAD") Dim D1 As Object, D2 As Object, D3 As Object Dim i%, a As Boolean, b As Boolean, c As Boolean Dim x%, Y%, m%, z%, Réf, ky, Rng$ Set D1 = CreateObject("Scripting.Dictionary"): Set D2 = CreateObject("Scripting.Dictionary") Set D3 = CreateObject("Scripting.Dictionary") With WSdest Application.ScreenUpdating = False WSdest.Range("M4:V32,X4:AG32,AI4:AR32").ClearContents i = 7 Do While i <= .Rows.Count If WSdest.Cells(i, 2) <> "" And WSdest.Cells(i, 2) <> HasFormula Then Rng = Mid(Trim(WSdest.Cells(i, 2)), 1, 1) Select Case Rng Case "3": a = True: b = False: c = False Case "2": b = True: a = False: c = False Case Else: b = False: a = False: c = True End Select Réf = Application.Transpose(.Cells(i, 2).Resize(, 13)) Réf = Application.Transpose(Réf) If a Then D3(z) = Join(Réf, "*"): z = z + 1 ElseIf b Then D2(Y) = Join(Réf, "*"): Y = Y + 1 Else D1(x) = Join(Réf, "*"): x = x + 1 End If i = i + 1 Else Exit Do End If Loop m = 4 If D3.Count Then For Each ky In D3 WSdest.Cells(m, "M").Resize(, 13) = Split(D3(ky), "*") m = m + 1 Next ky End If m = 4 If D2.Count Then For Each ky In D2 WSdest.Cells(m, "X").Resize(, 13) = Split(D2(ky), "*") m = m + 1 Next ky End If m = 4 If D1.Count Then For Each ky In D1 WSdest.Cells(m, "AI").Resize(, 13) = Split(D1(ky), "*") m = m + 1 Next ky End If WSdest.Range("M4").CurrentRegion.Value = WSdest.Range("M4").CurrentRegion.Value WSdest.Range("X4").CurrentRegion.Value = WSdest.Range("X4").CurrentRegion.Value WSdest.Range("AI4").CurrentRegion.Value = WSdest.Range("AI4").CurrentRegion.Value End With End Sub تقرير المصلحة.xlsm

اخي ربما ليس هناك مستحيل لاكن يتعين عليك شرح المطلوب بطريقة اوضح تقضل لقد حاولت الاشتغال على ملفك بطريقة متقدمة نوعا ما ربما تفيدك واستخراج النتائج على التيكست بوكس لكل نوع من الحركة بالاعتماد على ما فهت منك وهو عملية الجمع والطرح تكون بالشكل التالي Purchases + Sales returns - sales - Purchases returns واي استفسار او اظافة لا تتردد في دكره سوف تكون سعداء بحصولك على النتيجة المتوقعة Dim AllData(), the_range, wsdata, Target_columns(), Dates(), wsdata2, réf() Function MergeArray2DVert(A, B) maxtab1 = UBound(A) Dim tbl(): ReDim tbl(1 To UBound(A) + UBound(B), 1 To UBound(A, 2)) For I = LBound(A) To UBound(A) For C = 1 To UBound(A, 2): tbl(I, C) = A(I, C): Next Next I For I = 1 To UBound(B) For C = 1 To UBound(B, 2): tbl(maxtab1 + I, C) = B(I, C): Next Next I MergeArray2DVert = tbl End Function Private Sub UserForm_Initialize() 'دمج بيانات الجداول Dim Tablo1, Rng_1, rng2, T Tablo1 = [Tableau1]: Rng_1 = [Rng_2]: rng2 = [Rng_3]: rng3 = [Rng_4] AllData = MergeArray2DVert(Tablo1, Rng_1) AllData = MergeArray2DVert(AllData, rng2) AllData = MergeArray2DVert(AllData, rng3) the_range = "Tableau1" ' For i = 1 To UBound(AllData): AllData(i, 3) = CDate(AllData(i, 3)): Next i Me.ListBox1.ColumnCount = 8 wsdata = 8 'Target_columns = Array(1, 2, 3, 4, 6, 7, 8, 11) '(Total)في انتظار توضيح فكرة عمود Target_columns = Array(1, 2, 3, 4, 6, 7, 8) ' عمود التاريخ For I = LBound(AllData) To UBound(AllData): AllData(I, 3) = Format(AllData(I, 3), "dd/mm/yyyy"): Next I 'عمود الكمية For I = LBound(AllData) To UBound(AllData): AllData(I, 8) = Format(AllData(I, 8), "0"): Next I ' عمود Total 'For I = LBound(AllData) To UBound(AllData): AllData(I, 9) = Format(AllData(I, 9), "0.0"): Next I 'Combobox Product name Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 7)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox1.List = réf 'Combobox Invoice type Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 2)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox5.List = réf 'Combobox customer Set D = CreateObject("scripting.dictionary") D("*") = "" For I = LBound(AllData) To UBound(AllData) D(AllData(I, 4)) = "" Next I réf = D.keys filtration réf, LBound(réf), UBound(réf) Me.ComboBox4.List = réf 'combobox التاريخ Set D = CreateObject("scripting.dictionary") ligneData = 3 For I = LBound(AllData) To UBound(AllData) D(AllData(I, ligneData)) = "" Next I Dates = D.keys filtration Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) ComboBox1.Value = "*": ComboBox4.Value = "*": ComboBox5.Value = "*" Titles ShowAllData On Error Resume Next Me.ListBox1.ColumnWidths = "60;70;80;80;30;190;70;0" On Error GoTo 0 b_tout_Click End Sub '******************************************** Sub ShowAllData() Dim tbl() Dim F As Worksheet, B As Worksheet, S As Worksheet, D As Worksheet Set F = Sheet4: Set B = Sheet2: Set S = Sheet6: Set D = Sheet5 j = Me.ComboBox1: If j = "" Then j = "*" A = Me.ComboBox4: If A = "" Then A = "*" r = Me.ComboBox5: If r = "" Then r = "*" début = Me.ComboBox2 fin = Me.ComboBox3 ligneData = 3 ' عمود التاريخ n = 0 For I = LBound(AllData) To UBound(AllData) If AllData(I, ligneData) >= début And AllData(I, ligneData) <= fin And AllData(I, 7) Like j And AllData(I, 4) Like A And AllData(I, 2) Like r Then n = n + 1: ReDim Preserve tbl(1 To wsdata, 1 To n) C = 0 On Error Resume Next For Each k In Target_columns C = C + 1: tbl(C, n) = AllData(I, k) Next End If Next I If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear End If col = ListBox1.ListCount Call MH Me.Total.Value = Format(Sheet4.[Q1].Value, "0.00") TOTAL_all.Caption = "Total Quantity" & " = " & Format(Sheet4.Range("Q2").Value, "0.000") F.[O1] = "*": B.[O1] = "*": S.[O1] = "*": D.[O1] = "*" End Sub '******************************** Sub MH() Dim A As Worksheet, B As Worksheet, C As Worksheet, D As Worksheet, ws As Worksheet Dim Rng As Range For Each ws In ThisWorkbook.Worksheets Select Case ws.Name Case "Purchases", "sales", "Sales returns", "Purchase returns" Set Rng = ws.Range("O1") Rng.ClearContents Set A = Sheet4: Set B = Sheet2: Set C = Sheet6: Set D = Sheet5 If Me.ComboBox5.Value = "Purchases" And Me.ComboBox1.Value <> "*" Then A.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else A.Range("O1").Value = Empty If Me.ComboBox5.Value = "sales" And Me.ComboBox1.Value <> "*" Then B.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else B.Range("O1").Value = Empty If Me.ComboBox5.Value = "Sales returns" And Me.ComboBox1.Value <> "*" Then C.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value ' Else C.Range("O1").Value = Empty If Me.ComboBox5.Value = "Purchase returns" And Me.ComboBox1.Value <> "*" Then D.[N1].Value = Me.ComboBox5.Value: ws.[O1].Value = Me.ComboBox1.Value 'Else D.Range("O1").Value = Empty Me.Purchases.Value = Format(A.Range("P1").Value, "0.00") Me.sales.Value = Format(B.Range("P1").Value, "0.00") Me.Sales_returns.Value = Format(C.Range("P1").Value, "0.00") Me.Purchase_returns.Value = Format(D.[P1].Value, "0.00") Me.Total.Value = Format(A.[Q1].Value, "0.00") End Select Next ws End Sub sum-Listbox3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub CommandButton5_Click() Dim ws As Worksheet: Set ws = Sheets("دراسة فندق") Me.Label171.Caption = Format(ws.[F6].Text, "0,#%") 'Me.Label171.Caption = ws.Range("F6").Text 'دخل الحج Me.Label167.Caption = ws.[G6].Text 'دخل الحج Me.Label163.Caption = ws.[H6].Text 'دخل الحج Me.Label187.Caption = ws.[I6].Text 'دخل الحج Me.Label183.Caption = ws.[J6].Text 'دخل الحج Me.Label179.Caption = ws.[K6].Text 'دخل الحج Me.Label199.Caption = ws.[L6].Text 'دخل الحج Me.Label195.Caption = ws.[M6].Text 'دخل الحج Me.Label191.Caption = ws.[N6].Text 'دخل الحج 'رمضان Me.Label169.Caption = Format(ws.[F7].Text, "0,#%") 'دخل رمضان Me.Label165.Caption = ws.[G7].Text 'دخل رمضان Me.Label161.Caption = ws.[H7].Text 'دخل رمضان Me.Label185.Caption = ws.[I7].Text 'دخل رمضان Me.Label181.Caption = ws.[J7].Text 'دخل رمضان Me.Label177.Caption = ws.[K7].Text 'دخل رمضان Me.Label197.Caption = ws.[L7].Text 'دخل رمضان Me.Label193.Caption = ws.[M7].Text 'دخل رمضان Me.Label189.Caption = ws.[N7].Text 'دخل رمضان 'مواسم رمضان Label170.Caption = Format(ws.[F8].Text, "0,#%") 'دخل مواسم رمضان Label166.Caption = ws.[G8].Text 'دخل مواسم رمضان Label162.Caption = ws.[H8].Text 'دخل مواسم رمضان Label186.Caption = ws.[I8].Text 'دخل مواسم رمضان Label182.Caption = ws.[J8].Text 'دخل مواسم رمضان Label178.Caption = ws.[K8].Text 'دخل مواسم رمضان Label198.Caption = ws.[L8].Text 'دخل مواسم رمضان Label194.Caption = ws.[M8].Text 'دخل مواسم رمضان Label190.Caption = ws.[N8].Text 'دخل مواسم رمضان End Sub برنامج دراسة فندق_2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب Sub حفظ() Dim myFolder As String 'خلية اسم الملف NameSh = Range("b2") ' مجلد الحفظ myFolder = ThisWorkbook.Path & "\السجل\" & NameSh If NameSh = Empty Then: MH = MsgBox("المرجوا إضافة إسم الملف", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "تنبيه"): Exit Sub ActiveSheet.Copy '(VBA)' تعطيل تنبيهات Application.ScreenUpdating = False Application.DisplayAlerts = False ' تحويل الصيغ الى قيم With ActiveSheet.UsedRange .Value = .Value End With ' حدف الازرار For Each shape In ActiveSheet.Shapes shape.Delete Next ' افراغ الخلايا التي تتضمن 0 ActiveWindow.DisplayZeros = False On Error Resume Next With ActiveWorkbook .SaveAs Filename:=myFolder & ".xlsx", FileFormat:=51 ' في حالة الرغبة باظافة تاريخ اليوم ' .SaveAs Filename:=myFolder & "_" & Format(Now, "yy-mm-dd") & ".xlsx", FileFormat:=51 .Close False End With On Error GoTo 0 End Sub الحفظ.rar

اللهم أدخله برحمتك فسيح جناتك, اللهم أبدله دارا خير من داره وأهلا خيرا من أهله واجعله مع الصديقين والنبيين والشهداء وحسن أؤلئك رفيقـا -اللهم وسع مدخله وغسله بالماء والبرد.

بسم الله الرحمن الرحيم وبه نستعين والصلاة والسلام على اشرف الخلق والمرسلين هذا العمل صدقة جارية على روح والدة البشمهندس طارق محمود جزاه الله عنا خير الجزاء والله لانى اقدره واحترامه واقبل يديه وهذا البرنامج يرجع الفضل لله ثم للبشمهندس طارق قبل العمل على البرنامج برجاء مشاهدة فيديو الاستخدام حتى تجيد استخدام البرنامج واتركم مع البرنامج البرنامج به اكواد من المنتدى 1.rar الاصدار الرابع قوائم الطلاب.xlsm

بسم الله الرحمن الرحيم أخي العزيز تفضل هذه هي الأداتين المرفقتين قم بتسجيلهما أولا الأولى للصور المتحركة GIF الثانية للفلاش وتقبل تحياتي أخيك سهل أحمد ( ابو نعيم ) Gif89.rar swflash.rar