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

طيب اضف هذا السطر في فانك الفورمات لديك <<<<>>>>>>> .usedRange.ReadingOrder = -5004

تفضل اخي الكريم شهادات.xlsm

نعم أستاذى الكريم تم تعديل الأرقام إلى اللغة العربية .... وتم اضافة .. .usedRange.Columns(4).NumberFormat = "yyyy/mm/dd" لتعديل اتجاه التاريخ الى اليمين.. جزيل الشكر لحضرتك

اخي الكريم @Foksh يبدو اننا نجاوب في نفس الوقت . ههههه

تفضل أخي الكريم @sm44ms ، اجعل مصدر مربع النص ASQ هذا السطر :- =DCount("*";"Table1";"[Status] = 'استقالة'") وسيعطيك عدد السجلات التي الحالة للموظف = استقالة . طبعاً قمت بتغيير تسمية حقل ( حالة البطاقة ) إلى Status ؛ لتلافي الأخطاء في الكود مع وجود مسميات باللغة العربية . يا أخي أنا اليوم حظي وافر وجميل لمصادفتي لك مرتين متتاليتين

اكتب في مصدر عنصر التحكم ... =DCount("[حالة البطاقة]";"[Table1]";"[حالة البطاقة] ='استقالة'")

اعتذر أخي الكريم وأستاذنا @kanory على المداخلة ، قمت بالرد وتفاجأت بردك ومتابعتك بعد التحديث 😬

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_Sheet() 'انشاء ورقة جديدة وتسميتها وفق التسلسل المطلوب Dim f As Worksheet, Msg As Variant, Data As Worksheet Dim WSname As String, Cpt As String Set Data = Sheets("T1") WSname = "SMS" & Format(Date, "DDMMYY") Msg = MsgBox("انشاء ورقة جديدة؟", vbYesNo, WSname) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next Cpt = Worksheets(WSname).Name If Cpt = "" Then Data.Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) ' اظافة تاريخ واسم اليوم Set f = ActiveSheet f.Name = WSname: f.[E1].Value = Date: f.[C1].Value = Format(Date, "DDDD") '*******للاحتفاظ بالصيغ يمكنك الغاء هدا السطر With f.ListObjects(1).DataBodyRange .Value = .Value End With '********************************************** Else MsgBox "ورقة العمل موجودة مسيقا" & _ "", vbInformation, WSname End If .ScreenUpdating = True .DisplayAlerts = True End With End Sub Sub Save_folder_PDF() 'PDF '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String, Msg As Variant Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next path = ThisWorkbook.path & "\" folderName = "ملفات PDF" MkDir path & folderName Fname = folderName & "\" & WS.Name & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=path & Fname ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName On Error GoTo 0 End Sub Sub Save_folder_Excel() 'Excel '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Application.ActiveWorkbook.SaveAs fileName:=path & Fname & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName End Sub مع اظافة امكانية تنفيد الاكواد بطريقة اخرى ستجدها داخل الملف المرفق بالتوفيق... نمودج V2.xlsb