اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

السلام عليكم

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

وهى نصفين

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

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

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

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

قام بنشر (معدل)

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

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

تم تعديل بواسطه abouelhassan
  • Like 2
قام بنشر

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

image.png.3bd128198559e1a9445a2ed78b2e079e.png

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

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

الخلية D3

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

image.png.21abd1bfa77ac0a6a2091b2431de5e34.png

قام بنشر

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

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

  • Like 2
قام بنشر

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

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

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

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

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

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

 

قام بنشر
12 ساعات مضت, ابو محمد 4 said:

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

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

قام بنشر

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

نعم اقصد ان يتم الحفظ فى المسار القريص 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

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information