المساعدة فى حفظ ورقة العمل بشكل مستقل مع الاحتفاظ بالتنسيق و المعادلات

[ابو محمد 4]

السلام عليكم

فى الملف المرفق ورقة عمل باسم الفاتورة

وهى نصفين

ارغب فى حفظ ورقة العمل كمل اكسيل مستقل فى نفس مجلد الملف الاصلى وباسم العميل

مع تحويل المعادلات فى النصف العلوى من الفاتورة الى قيم والاحتفاظ بالمعادلات فى القسم الثانى

بارك الله فيكم

حسابات احمد.xlsx

[abouelhassan]

Sub SaveAsNewWorkbook()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim folderPath As String
    Dim clientName As String
    Dim lastRow As Long
    
    ' تحديد المجلد المحتوي على الملف الأصلي
    folderPath = ThisWorkbook.Path
    
    ' اسم العميل (يمكنك تغيير هذا إلى الطريقة التي تريد استخدامها لاستخراج اسم العميل)
    clientName = "اسم العميل"
    
    ' تكوين اسم الملف الجديد
    newFileName = folderPath & "\" & clientName & ".xlsx"
    
    ' نسخ ورقة العمل الحالية إلى مصفوفة
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    ws.Copy
    
    ' حفظ المصفوفة كملف إكسل جديد
    Set newWb = ActiveWorkbook
    Set newWs = newWb.Sheets(1)
    Application.DisplayAlerts = False
    newWb.SaveAs newFileName, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ' تحويل المعادلات في النصف العلوي من الفاتورة إلى قيم
    lastRow = newWs.Cells(Rows.Count, "A").End(xlUp).Row
    newWs.Rows("1:" & lastRow \ 2).Value = newWs.Rows("1:" & lastRow \ 2).Value
    
    ' إظهار رسالة تأكيد الحفظ
    MsgBox "تم حفظ الملف كـ" & newFileName, vbInformation, "تم الحفظ"
End Sub

يرجى ملاحظة أنه يجب استبدال "اسم العميل" بالطريقة التي تريد استخدامها لاستخراج اسم العميل

تم تعديل فبراير 24 بواسطه abouelhassan

[ابو محمد 4]

بارك الله فيكم معلمى الفاضل

لم استطع التنفيذ

وارجوا عند الحفظ ياخذ اسم الملف من اسم العميل بالفاتورة 

الخلية D3

هذا الجذء الذى ارغب فى تحويله الى قيم

[محمد هشام.]

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

Sub SaveFile_Excel()
'في نفس مسار المصنف الرئيسي Excel 'حفظ بصيغة

Dim WS As Worksheet, Client As String, path As String, Msg As Variant
path = ThisWorkbook.path & "\"
Set WS = Worksheet____3: Client = [D3].Value

If Len([D3].Value) = 0 Then: MsgBox "المرجوا إظافة إسم العميل", vbExclamation, "Admin": Exit Sub
    Msg = MsgBox(" تصدير الملف" & " : " & "فاتورة" & " " & Client & "؟", vbYesNo, "Admin")
      If Msg <> vbYes Then Exit Sub
      
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False

    WS.Copy
    Set rng = [B1:F22]
    With rng
        .Value = .Value
        .Validation.Delete
    End With
    For Each shape In ActiveSheet.Shapes
           shape.Delete
    Next
    Application.ActiveWorkbook.SaveAs Filename:=path & Client & ".xlsx", FileFormat:=51
    
'<-- اظافة التوقيت
' Application.ActiveWorkbook.SaveAs Filename:=Path & Client & "-" & Format(Time, "HH-mm-ss") & ".xlsx", FileFormat:=51
      
      ActiveWorkbook.Close
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

 MsgBox "تم نسخ الملف بنجاح" & _
    "", vbInformation, Client
End Sub

 

حسابات احمد.xlsb

[ابو محمد 4]

بارك الله فيكم استاذى الفاضل

وخالص تحياتى لشخصكم الكريم

بالفعل هذا هو المطلوب 

ولى رجاء بسيط هل يمكن اضافه خبار حفظ الشيت بي دي اف فى نفس الفولدر باسم العميل

وهل يمكن ايضا اذا كان هناك ملف باسم العميل سابقا يقوم بحقظ الملف الجديد باسم العميل + رقم ولا يقوم بحذف الملف القديم

بارك الله فيكم جعله فى ميزان حسناتكم

 

[محمد هشام.]

12 ساعات مضت, ابو محمد 4 said:

ولى رجاء بسيط هل يمكن اضافه خبار حفظ الشيت بي دي اف فى نفس الفولدر باسم العميل

الملف يتم حفظه فعلا في نفس مسار الملف هل تقصد  حفظه في مجلد معين او انشاء مجلد جديد في نفس مسار الملف 

[ابو محمد 4]

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

نعم اقصد ان يتم الحفظ فى المسار القريص d , وفى مجلد الفواتير

وعند تكرار الاسم يتم الاعلام بذلك 

وهل يمكن اضافة زر للحفظ ك بي دي اف ؟

[محمد هشام.]

تفضل اخي 

Sub SaveFile_Excel()
Dim wb As Workbook, desWS As Worksheet
Set wb = ThisWorkbook: Set desWS = wb.Sheets("الفاتورة ")
Dim a(1 To 3) As String
Dim shape  As shape: Dim rng  As Range
'اسم الملف
a(1) = desWS.[D3].Value

 With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
On Error Resume Next

   'اسم مجلد الحفظ قم بتعديله بما يناسبك
  
  a(2) = "Excel فواتير المبيعات"
 
'***********'لحفظ الملف في نفس مسار المصنف الرئيسي*********
' a(3) = Application.ActiveWorkbook.Path & "\" & a(2)

'*************لحفظ الملف في بارتيشن من اختيارك*************

' قم بتحديد اسم البارتيشن الخاصة بك

    a(3) = "D:\" & a(2)
 
' انشاء المجلد في حالة عدم العثور عليه
 If Dir(a(3), vbDirectory) = "" Then MkDir a(3)
  Cpt = Dir(a(3) & "\" & a(1) & "*")
  
  desWS.Copy
Set rng = [B1:F22]
    With rng
       .Value = .Value: .Validation.Delete
    For Each shape In ActiveSheet.Shapes
            shape.Delete
    Next
 End With
    ' تسلسل اسم الملف
  F = 0
  Do While Cpt <> ""
    F = F + 1
    Cpt = Dir
  Loop
  
   '(Excel بصيغة)'   ' حفظ الملف في المسار التالي
  Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51
  ' غلق المصنف
ActiveWorkbook.Close
DisplayAlerts = True
    .ScreenUpdating = True
End With

MsgBox "تم نسخ ملف " & " " & a(1) & " " & " بنجاح" & vbLf & vbLf & a(3) & _
      "", vbInformation, "ملف رقم :" & " " & F + 1

End Sub

لحفظ الملف بصيغة PDF قم بتعديل هدا السطر 

 '(PDF بصيغة)'    

   Application.ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=a(3) & "\" & a(1) & "_" & F + 1

 

حسابات احمد Excel & PDF.xlsm

[محمد هشام.]

لقد ألقيت نظرة أكثر قليلاً على الكود الخاص بي ، وقمت بحساب عدد الملفات الموجودة بالفعل في المجلد. واكتشفت أنه إذا قمت بحذف أي من الإصدارات الأقدم، فسيخرج رقم الإصدار  الجديد من المزامنة ولن يستخدم الرقم الأحدث. إذا كنت مهتم بتجربة إصدار آخر،

فاستبدل هذا الرمز:

'  ' تسلسل اسم الملف
     F = 0
  Do While Cpt <> ""
    F = F + 1
    Cpt = Dir
  Loop
 '(Excel بصيغة)'   ' حفظ الملف في المسار التالي
  Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51

بهذا الكود:

  ' تسلسل اسم الملف
    Dim sVers As String
    Dim Réf As Long, F As Long
    Dim i As Long

    Do While Cpt <> ""
        sVers = Right(Left(Cpt, InStr(Cpt, ".xls") - 1), 4)
        Réf = 0
        For i = Len(sVers) - 1 To 1 Step -1
            If IsNumeric(Right(sVers, i)) Then
                Réf = Val(Right(sVers, i))
                Exit For
            End If
        Next i
        If F < Réf Then F = Réf
        Cpt = Dir
    Loop

   '(Excel بصيغة)'   ' حفظ الملف في المسار التالي
    Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51