كود لتصدير شيت اكسيل إلي إكسيل علي الكمبيوتر

[محمود رمضان السمري]

عندي واجهه يوزر فورم وعاور أعمل زر (commandButton) بكود حفظ sheet18 بصيغه اكسيل علي الكمبيوتر ويحفظ بالاسم الموجود في خلية e2 ولكم جزيل الشكر

[محمد هشام.]

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

جرب هدا 

Private Sub CommandButton1_Click()
Dim newWb As Workbook
Dim WS As Worksheet: Set WS = Sheets("Sheet18")

Path = ThisWorkbook.Path & "\"   'OR =====>>'"D:\test\"
If WS.[E2] = 0 Then: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False

WS.Copy
Set newWb = ActiveWorkbook
newWb.SaveAs Filename:=Path & WS.[E2] & ".xlsx", FileFormat:=51
newWb.Close
   
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True

    MsgBox "Saved successfully"
End Sub

 

SAV 18.xlsb

[محمود رمضان السمري]

الله ينور عليك

بس كنت عاوز اغير مسار الحفظ لأي مكان غير مكان البرنامج

[محمود رمضان السمري]

وبعد إذنك يكون الحفظ بدون المعادلات

[محمد هشام.]

 

 او جرب هدا ربما هدا ما تقصده 

Private Sub CommandButton1_Click()
Dim WS As Worksheet, NewWb As Workbook
Dim Path As Variant
Set WS = Worksheets("Sheet18")

If WS.[E2] = 0 Then: Exit Sub

'Path = "D:\test\"   في حالة كان المسار ثابت يمكنك تعديل السطر التالي بما يناسبك '

' اختيار مسار الحفظ
Path = Application.GetSaveAsFilename(InitialFileName:=WS.[E2], _
fileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="الرجاء اختيار مكان الحفظ")
If Path <> False Then

Application.DisplayAlerts = False
Application.ScreenUpdating = Fals

WS.Copy
Set NewWb = ActiveWorkbook
    With NewWb.Sheets(1).UsedRange
        .Value = .Value
    End With
   NewWb.SaveAs Path, FileFormat:=51
   '****************************************************************
  '  هدا للمسار الثايت
'   NewWb.SaveAs Filename:=Path & WS.[E2] & ".xlsx", FileFormat:=51
'*********************************************************************
   NewWb.Close
     
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
    
    MsgBox "Saved successfully"
       Unload Me
    End If
End Sub

 

SAV 18 v2.xlsb

تم تعديل أغسطس 20 بواسطه محمد هشام.

[محمود رمضان السمري]

افادكم الله .الله ينور عليك ألف شكر استاذ محمد

تم تعديل أغسطس 20 بواسطه محمود رمضان السمري