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

[قلبي دليلي]

الأخوة الأعزاء

 

بعد التحية ،،

 

يوجد لدي ملف اجتهدت فيه بعد القراءة كثيرا في المنتديات كان هدفي منه تحسين مستوى العمل وتقليص الدورة المستندية وسرعة انجاز العمل.

 

 

طريقة عمل الملف كالتلي :

 

1- يتم تعبئة البانات من قبل الدعم الفني .

2- يتم ارسال الملف بشكل آلي بالضغط على ايقونة الارسال ( ويتم بشكل الى حفظ الملف باسم جديد يعتمد على رقم الطلب واللوحة ويكون هناك تلقائياً رسالة داخل البريد .

3- يتم الضغط على ايقونة حفظ ومسح وذلك ليتم تغيير الرقم الخاص بالطلب تلقائيا ويتم مسح محتويات الطلب السابق بشكل الي.

4- يقوم قسم خدمات الاسطول بفتح البريد يضغط على حفظ الملف كطلب معلق حسب الايقونة ويتم حفظه بنفس الاسم في مجلد خاص يتم انشاؤه في جهاز الكمبيوتر للمتابعة فقط.

5- عند الانتهاء من الطلب يتم فتحه وكتابة الملاحظات حسب الخانات الموضحة بالملف ومن ثم يتم ارسال البريد للجهة المعنية حسب الايقونة الخاصة بها وأيضا تم برمجتها لتكون بشكل الي والشرح بشكل الي.

6- تم حفظ الملف الذي تم ارساله بالضغط على ايقونة حفظ ليتم حفظ الملف في جهاز الكمبيوتر في مجلد الكلبات التي تم اصلاحها واقفالها.

7- يتم فتح الملف من قبل الدعم الفني ويتم تعبئة البيانات النهائية الخاصة بالطلب ومن ثم يتم حفظ الملف بشكل نهائي على أنه تم اقفاله بشكل الي أيضا.

 

المشكلة التي واجهتها هي أنه عند الخطوة رقم 5 عند فتح الملف الذي تم حفظه باسم جديد كمعلق لا يكون فيه الماكرو ولا يتم عمل الايقونات ، حاولت عمل ماكرو شخصي وواجهتني مشكلة ايضا .

 

أريد أن يتم الربط بين الجهازين بدون أي مشاكل في الماكرو الذي يختفي عند حفظ الملف باسم جديد.

 

لا أستطيع ارفاق الملف ولا أعلم السبب

 

Sub NextInvoice()
    Range("O8").Value = Range("O8").Value + 1
    Range("U11:AA16").ClearContents
    Range("M11:O16").ClearContents
    Range("A11:H16").ClearContents
    Range("C22:AB31").ClearContents
    Range("O17:O18").ClearContents
End Sub

Sub SaveInvWithNewName()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\JOB ORDER\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
    NextInvoice
End Sub

    Sub Email_CurrentWorkBook_Hoobers()
      
        'Do not forget to change the email ID
        'before running this code
      
        Dim OlApp As Object
        Dim NewMail As Object
        Dim TempFilePath As String
        Dim FileExt As String
        Dim TempFileName As String
        Dim FileFullPath As String
        Dim MyWb As Workbook
      
        Set MyWb = ThisWorkbook
      
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
      
        'Save your workbook in your temp folder of your system
        'below code gets the full path of the temporary folder
        'in your system
      
        TempFilePath = Environ$("temp") & "\"
        'Now get the extension of the file
        'below line will return the extension
        'of the file
        FileExt = "." & LCase(Right(MyWb.Name, Len(MyWb.Name) - InStrRev(MyWb.Name, ".", , 1)))
        'Now append a date and time stamp
        'in your new file
     
        TempFileName = Range("AK3").Value
     
        'Complete path of the file where it is saved
        FileFullPath = TempFilePath & TempFileName & FileExt
     
        'Now save your currect workbook at the above path
        MyWb.SaveCopyAs FileFullPath
     
        'Now open a new mail
     
        Set OlApp = CreateObject("Outlook.Application")
        Set NewMail = OlApp.CreateItem(0)
     
        On Error Resume Next
        With NewMail
        .To = "fahad.mohammad@lsclogistics.com"
        .BCC = "algarni.fahad@gmail.com"
        .Subject = Range("AK2").Value
        .Body = "ãÑÝÞ áßã ØáÈ ÕíÇäÉ ááÔÇÍäÉ ÇáãÑÝÞÉ ÈíÇäÇÊåÇ ÃÚáÇå ¡ ÃÑÌæ ãäßã ÊÚãíÏ ãä íáÒã ÈÑÝÚ ÊÞÑíÑ áäÇ ÈÚÏ ãÚÇíäÊåÇ ÍÓÈ ÇáäÙÇã ÇáãÊÈÚ"
            .Attachments.Add FileFullPath '--- full path of the temp file where it is saved
            .Send   'or use .Display to show you the email before sending it.
        End With
        On Error GoTo 0
      
        'Since mail has been sent with the attachment
        'Now delete the temp file from the temp folder
      
        Kill FileFullPath
      
        'set nothing to the objects created
        Set NewMail = Nothing
        Set OlApp = Nothing
      
        'Now set the application properties back to true
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
      
    End Sub

Sub SaveInvWithNewName_FleetService()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\JOB ORDER CLOSE\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
End Sub

Sub SaveInvWithNewName_Pending()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\JOB ORDER PENDING\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
End Sub
Sub SaveInvWithNewName_Close()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\JOB ORDER CLOSE\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
End Sub

Sub RunExcelMacro()
Dim xl As Object
'Step 1:  Start Excel, then open the target workbook.
    Set xl = CreateObject("Excel.Application")
    xl.Workbooks.Open ("C:\Users\Fahad\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.xlsm")

'Step 2:  Make Excel visible
    xl.Visible = True

'Step 3:  Run the target macro
    xl.Run "JobOrder"

'Step 4:  Close and save the workbook, then close Excel
    xl.ActiveWorkbook.Close (True)
    xl.Quit

'Step 5:  Memory Clean up.
    Set xl = Nothing

End Sub

 

 

وشكراً

 

[طارق محمود]

السلام عليكم
أخي الكريم

أولا : أهلا ومرحبا بك بين إخوانك

 

ثانيا: لإرفاق الملف

إضغطه أولا وارسل النسخة المضغوطة

للضغط استخدم winrar أو  winzip

[قلبي دليلي]

أخ طارق

 

الف شكر لك على المعلومة القيّمة

 

تم ارفاق الملف

 

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

 

ولكم كل الشكر والتقدير

Job Order Test 1.rar

[طارق محمود]

السلام عليكم

أخي العزيز

من أحد الملفات الشغالة التي ليس بها مشاكل وبها الماكرو شغال إحفظ بإسم (مافيه تفعيل الماكرو - xlsm)

واضغط هذا الأخير

ثم إرفقه

كما يفضل ذكر أي من هذه الأزرار الذي يتعطل بالخطوة 5

[قلبي دليلي]

أبشر أخي الكريم

 

سيتم عمل اللازم

 

وفي نفس الوقت سيتم توضيح المشكلة

[قلبي دليلي]

هذه صورة الخطأ

 

عند الانتهاء من النقطة رقم 5 من قبل قسم خدمات الأسطول ننتقل للخطوة رقم 6 وهي حفظ الملف الذي تم ارساله في مجلد الطلبات المغلقة.

 

يظهر لي هذا الخطأ المرفق

[قلبي دليلي]

الملف بعد التعديل وتغيير ملف الحفظ ليكون بدون ماكرو

Job Order Test.rar

تم تعديل أبريل 23, 2013 بواسطه Mr.FaHaD

[قلبي دليلي]

 

تم تعديل أبريل 23, 2013 بواسطه Mr.FaHaD

[طارق محمود]

السلام عليكم

أخي العزيز

الكود الأول في مشاركتك الأولي كان مضبوط ويسجل بصيغة xlsm التي تقبل الماكرو

أما الكود الذي بالملف في مشاركتك الأخيرة غير مضبوط ويسجل بصيغة xlsء التي لاتقبل الماكرو

 

تم التعديل للازم

مع عدم التجربة

أرجو أن تجربه وتعطيني النتيجة

Job Order Test2.rar

[طارق محمود]

بمعني آخر 

ستجد الكود أربع مواضع فيها التسجيل بصيغة xlsx

مثل

 

NewFN = "D:\Technical Support Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsx"

    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbook

 

فما عليك إلا تغييرها إلي

 

NewFN = "D:\Technical Support Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"

    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled

 

[قلبي دليلي]

أشكرك أخي الكريم

 

ولكنها كانت بهذا الشكل سابقا وتم تعديلها بناء على فهمي البسيط لاقتراحكم الأول بحفظها بصيغة ما فيه تفعيل ماكرو

 

لسلام عليكم

أخي العزيز

من أحد الملفات الشغالة التي ليس بها مشاكل وبها الماكرو شغال إحفظ بإسم (مافيه تفعيل الماكرو - xlsm)

واضغط هذا الأخير

ثم إرفقه

كما يفضل ذكر أي من هذه الأزرار الذي يتعطل بالخطوة 5

 

 

ستتم التجربة الآن والعودة لك أخي الحبيب وتقبل شكري

[قلبي دليلي]

أستاذي الفاضل

 

تمت التجربة

بعد ارسال الرسالة واستلامها من الطرف الآخر وبعد فتحها

وعند الضغط على ( Save as pending ) تظهر لي نفس العلامة ونفس المشكلة

 

 

الماكرو الخاص به هو هذا

 

Sub SaveInvWithNewName_Pending()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\Fleet Service Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
End Sub

 

 

كما أحب أن أسال عن هذا الكود

 

Sub SaveInvWithNewName()
    Dim NewFN As Variant
    ' Copy Invoice to a new workbook
    ActiveSheet.Copy
    NewFN = "D:\Technical Support Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
    
     '       ActiveWorkbook.SaveAs Filename:="C:\Users\tareq\Documents\assasa.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
    NextInvoice

 

لأنه جديد وأحب أن أفهم معناه

 

واعتذر منك مقدما وشاكر لك جهودك معي

تم تعديل أبريل 23, 2013 بواسطه Mr.FaHaD

[طارق محمود]

السلام عليكم

هذه الجزئية

 '       ActiveWorkbook.SaveAs Filename:="C:\Users\tareq\Documents\assasa.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

 

 

 

 

ببساطة يمكنك عمل Save as أثناء تشغيل مسجل الأكواد لتري محرر الأكواد كيف يكتب هذا الأمر

إذا لاحظت في الملف الذي أرسلته أنا تجد في الـ Module3 كود Macro1 فقط للحفظ بإمتداد xlsm

[طارق محمود]

السلام عليكم

الحمد لله ، تم معرفة الخطأ

 

المفروض نسخ الملف وليس الورقة 

أبطلت عمل سطر نسخ الورقة      ActiveSheet.Copy

وأضفت بدلا منه نسخ الملف

وفي المقابل أضفت حلقة لإزالة جميع ورقات الملف المنسوخ عدا تلك التي بها الأزرار

تفضل الكود

Sub SaveInvWithNewName_Pending()
    Dim NewFN As Variant
    OldFN = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
    ' Copy Invoice to a new workbook
    ' ActiveSheet.Copy
    Application.DisplayAlerts = False
   
     NewFN = "D:\Fleet Service Job Order Pending\Inv" & Range("O8") & Range("AI1") & Range("U11").Value & ".xlsm"
    ActiveWorkbook.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    X = ActiveSheet.Name
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> X Then Sheets(i).Delete
    Next
    FN = ActiveWorkbook.Name
    Workbooks.Open (OldFN)
    Workbooks(FN).Close
    Application.DisplayAlerts = True
   
End Sub

[قلبي دليلي]

أخي الحبيب

 

أعتذر  لعدم الرد عليك سابقاً لوجود مشكلة بالسيرفر الخاص بالعمل .

 

تمت تجربة الملف اليوم وهو يعمل بشكل ممتاز على كل الأجهزة وبشكل سليم وآلي.

 

جزاك الله كل خير ونفع بك