تعديل على كود حفظ باسم

[علي حيدر]

 التعديل على الكود بحيث يبقي الملف الاساسي مفتوح وغلق تلقائي للنسخه المستحدثة الملف مرفق مع الشرح وهذه نسخه عن الكود

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As String
 Dim Destwb As Workbook
Dim path As String

path = "D:\hhh\"
If Target.Column = 3 Then
lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value

End If
With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

  Set Destwb = ActiveWorkbook
 
With Destwb

  .SaveAs Filename:=path & lr, FileFormat:=52
        .Close SaveChanges:=False
    End With
    MsgBox "You can find the new file in " & lr
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   
   
   
End Sub

نرجو من الاساتذه المشاركه مع خالص تحياتي

[بن علية حاجي]

السلام عليكم

جرب الكود المعدل التالي:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As String
Dim Destwb As Workbook, Source
Dim path As String

Source = ThisWorkbook.FullName

path = "D:\hhh\"

If Target.Column = 3 Then
  lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value
End If

With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

Set Destwb = ActiveWorkbook
 
With Destwb
  .SaveAs Filename:=path & lr, FileFormat:=52
End With

Workbooks.Open Source
 
MsgBox "You can find the new file in " & lr

Destwb.Close

With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With

End Sub

بن علية حاجي

[علي حيدر]

شكرا جزيلا اخي بن علية حاجي على النظر في امري ولكنه اولاً لا يحفظ المتغيرات في الملف الأساسي ثانياً عند وجود اكواد أخرى في مودل وفورم  لا يعمل الكود ابداً ارجو االنظر وشكرا على الاهتمام مره اخرى

[علي حيدر]

شكرا لكم لقد حلت واللحمدلله

Private Sub Worksheet_Change(ByVal Target As Range)

Dim lr As String
Dim Destwb As Workbook, Source
Dim path As String
ThisWorkbook.Save
Source = ThisWorkbook.FullName

path = "D:\hhh\"

If Target.Column = 3 Then
  lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value
End If

With Application
   .ScreenUpdating = False
   .EnableEvents = False
End With

Set Destwb = ActiveWorkbook
 
With Destwb
  .SaveAs Filename:=path & lr, FileFormat:=52
End With

Workbooks.Open Source
 
MsgBox "You can find the new file in " & lr

Destwb.Close

With Application
   .ScreenUpdating = True
   .EnableEvents = True
End With
End Sub