حسين مامون

استاذي احمد بدرة جزاك الله خير الجزاء تحياتي

ربما يستحسن استعمال هذا مني طلب مساعده من منتدى اوفسينا (2) (1).xlsm

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

اخواني اساتذتي Ali Mohamed Ali و سليم حاصبيا واخرون ، انه لشرف لي ان أكون بين عظماء مثلكم واتمنى من العلي القدير ان ينور قلوبنا وان يتقبل منا ومنكم جميع اعمالنا وان نكون عند حسن ظن جميع اعضاء هذا الصرح العظيم. اشكركم جميعا تحياتي

وجزيت خيرا اخي

لا اعرف سبب المشكلة انا شغال عندي 100/100

قم بتعديل الكود او انسخ الجزء بين السطرين فقط واضفه للكود عندك Private Sub CommandButton1_Click() ' saveas_facture() Dim wx As Workbook Set wx = Workbooks("ÝÇÊæÑÉ") Dim ws As Worksheet Set ws = wx.Sheets("invoice") Dim wss As Worksheet Set wss = wx.Sheets("sheet1") Dim DT Dim Nam Dim lr As Long Application.ScreenUpdating = False Application.EnableEvents = False lr = wss.Range("a" & Rows.Count).End(xlUp).Row + 1 DT = ws.Range("e5") & Format(Now(), "dd-mm-yyyy hh mm ss") With ws ' .Copy ' .UsedRange = .UsedRange.Value Application.DisplayAlerts = False ' Nam = "d:\back\backup\ÝÇÊæÑÉ" & DT & ".xlsx" Nam = .Range("e5") & " " & Format(Now(), "dd mm yyyy hh mm ss") ThisWorkbook.SaveCopyAs Filename:="D:\back\Backup\" & Nam & ".xlsm" ' ActiveWorkbook.SaveAs Nam, FileFormat:=xlOpenXMLWorkbook '========================================= If ws.[f5].Text = "اجل" Then wss.Range("a" & lr).Value = Nam wss.Range("a" & lr).Font.Color = 255 Else: wss.Range("a" & lr).Value = Nam End If '======================================== ' ActiveWorkbook.Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "Êã ÍÝÙ äÓÎÉ ÈÇÓã " & DT & " ", vbInformation End Sub

جرب المرفق الصندوق2019 (2).xlsm

جرب المرفق back.rar

عفوا اخي الكريم /////////////////// وجزيت خيرا

هناك فقط ملاحظة مثلا لايمكن حفظ نسخة باسم سعيد دائما لازم اضافة وقت ليعمل الكود سيكون اسم الملف هكذا / سعيد 22:43:09 /

ممكن ولكن لا استطيع الان اجيبك من الهاتف

اخي الكريم قم بانشاء مجلد factur في Documents انا جربته وهو 100/100 هذه صورة داخل مجلد factur بعد تنفيذ الكود ان لم يعمل ارسل صورة للمستندات او documents المكتبة الصوتية.xlsm

وجزيت خيرا اخي الكريم

اخي الكريم بذون ملف نمودج لما تريد يستحيل فهم السؤال ولكن جرب الكود الكود يعمل على نسخ صفحات الملف باستثناء Sheet2 يخزنها في مجلد باسم factur على سطح المكتب قم بانشاء مجلد على سطح المكتب وسميه factur ملاحظة يجب ان يكون في الشيتات بيانات Private Sub CommandButton1_Click() Dim fName As String Application.ScreenUpdating = False Dim sh As Worksheet For Each sh In Sheets With sh If .Name = "Sheet2" Then GoTo 1 .Activate fName = ThisWorkbook.Name & .Name & Format(Now(), "dd-mm-yyyy- hh.mm.ss") ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ "C:\Users\" & Environ("UserName") & "\Desktop\" & "\factur\" & fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End With 1: Next sh Application.ScreenUpdating = True Sheets("Sheet2").Activate End Sub حفظ بي دي اف.xlsm

تفضل back.rar

اخي الكريم في مثل هذا البحث من الاحسن تصميم فورم يحتوي على combobox لادراج اسماء الشيتات و listbox لاستدعاء بيانات من الشيت الذي تختاره في combobox . وtsxtbox حسب العدد المطلوب لاظهار النتيجة المختارة من listbox وهذا رأيي فقط تحياتي

ضع الكود في حدث اغلاق الملف Private Sub Workbook_BeforeClose(Cancel As Boolean) With Sheets("main") .[d3] = Val(.[d3]) + 1 .[d4] = Format(Now(), "dd-mm-yyyy hh:mm:ss") End With End Sub

جرب هذا المرفق back.rar

اخي الكريم اظن ان من الاحسن وضع هذا السؤال في موضوع جديد وانا ساعمل على هذا مع اساتذة المنتدى والى هنا انتهينا تحياتي

اضغط زر حفظ نسخة وانظر شيت 1 كانت فاتورة سعيد واضفنا عبد السلام ثم قمنا بحفظ نسخة وفي شيت1 تم ترحيل اسم الفاتورة ايضا

Private Sub Workbook_Open() Sheets("ورقة1").Activate End Sub هذا مثال لجواب السؤال الثاني اما السؤال الاول كما اجابك الاستاذ احمد يوسف

اخي الكريم وجزيت خيرا انسخ المجلد الى D: وجرب Private Sub CommandButton1_Click() ' saveas_facture() Dim ws As Worksheet Set ws = Sheets("invoice") Dim wss As Worksheet Set wss = Sheets("sheet1") Dim DT Dim Nam Dim lr As Long Application.ScreenUpdating = False Application.EnableEvents = False lr = wss.Range("a" & Rows.Count).End(xlUp).Row + 1 DT = ws.Range("e5") & Format(Now(), "dd-mm-yyyy hh mm ss") With ws .Copy .UsedRange = .UsedRange.Value Application.DisplayAlerts = False Nam = "d:\back\backup\فاتورة" & DT & ".xlsx" ActiveWorkbook.SaveAs Nam, FileFormat:=xlOpenXMLWorkbook wss.Range("a" & lr).Value = ActiveWorkbook.Name ActiveWorkbook.Close False End With Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "تم حفظ نسخة باسم " & DT & " ", vbInformation End Sub back.rar

جزاك الله خيرا استاذ عمل رائع