احتاج اضافات للاكسل ادناة

[أبو قاسم]

السلام عليكم رحمة الله وبركاتة

 

نمودج.xlsb 

 

نمودج.xlsb

تم تعديل يناير 22, 2024 بواسطه أبو قاسم
اضافة

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

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

[أبو قاسم]

جزاك الله خير مبدع ولك كل الشكر والتقدير