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

[ashhma79]

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

عند استخدام زرار فتح مستند aa.xlsb فى جهاز الكمبيوتر يتم فتح المستند

و عند نقل البرنامج الى كمبيوتر اخر فلا يعمل الكود لتغيير اسم الجهاز

Set bb = Workbooks.Open("C:\Users\mcc\Desktop\aa.xlsx")
هل يمكن تغيير الكود ليعمل على على اسم جهاز كمبيوتر و ذلك عند نقله الى اى جهاز

بارك الله فى جميع اعضاء المنتدى

https://www.mediafire.com/file/xlqlo6we0mhuv2a/bb.xlsb/file

[hegazee]

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

نعم، يمكن تعديل الكود ليعمل على فتح الملف من أي كمبيوتر بشرط أن يتم اختيار الملف يدويًا من خلال نافذة اختيار الملفات

(File Dialog)، بدلاً من تحديد مسار ثابت مثل

C:\Users\....

إليك أخي الكريم الكود المعدل ليعرض نافذة لاختيار الملف يدويًا:

 

Sub ImportDataFromAnotherExcelFile()
    Dim FilePath As String
    Dim wb As Workbook
    
    ' فتح نافذة اختيار الملف
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "اختر ملف Excel"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
        
        If .Show = -1 Then ' تم اختيار الملف
            FilePath = .SelectedItems(1)
        Else
            MsgBox "لم يتم اختيار أي ملف.", vbExclamation
            Exit Sub
        End If
    End With
    
    ' فتح الملف
    Set wb = Workbooks.Open(FilePath)
    
    ' يمكنك الآن استخدام wb كمؤشر للملف المفتوح
    MsgBox "تم فتح الملف بنجاح: " & wb.Name
End Sub

 

 

bb2.xlsb

[محمد هشام.]

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

هناك عدة حلول تعتمد على طريقة عملك منها

استخدام USERPROFILE لجعل مسار الملف ديناميكيا _ وضع المصنف في نفس مجلد ملف الماكرو 

 أو السماح للمستخدم باختيار الملف يدويا (Browse) كما أشار الأخ الفاضل @hegazee

اليك الأكواد بالترتيب المدكور يمكنك إختيار ما يناسبك 

Sub OpenWorkbook1()
    Dim xPath As String, CrWS As Workbook
    On Error GoTo ErrHandler
    xPath = Environ("USERPROFILE") & "\Desktop\aa.xlsb"  ' OR <===== aa.xlsx
    If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: Exit Sub
    Set CrWS = Workbooks.Open(xPath)
    MsgBox "تم فتح الملف بنجاح", vbInformation
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

'===================================================

Sub OpenWorkbook2()
    Dim xPath As String, CrWS As Workbook
    On Error GoTo ErrHandler
    xPath = ThisWorkbook.Path & "\aa.xlsb" ' OR <===== aa.xlsx
    If Dir(xPath) = "" Then MsgBox " :الملف غير موجود" & vbNewLine & vbNewLine & xPath, vbExclamation: Exit Sub
    Set CrWS = Workbooks.Open(xPath)
    MsgBox "تم فتح الملف بنجاح", vbInformation
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

'==================================================

Sub OpenWorkbook3()
    Dim xPath As String, CrWS As Workbook
    On Error GoTo ErrHandler
    xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*")
    If xPath = "False" Then MsgBox "تم إلغاء العملية", vbInformation: Exit Sub
    Set CrWS = Workbooks.Open(xPath)
    MsgBox "تم فتح الملف بنجاح: " & xPath, vbInformation
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

وفي حالة الرغبة  في التحقق من أن إسم الملف الذي يختاره المستخدم يطابق إسم معين  مثلا  aa.xlsb  قبل فتح الملف

Sub OpenWorkbook4()
    Dim xPath$, CrWS As Workbook,Sname$
    On Error GoTo ErrHandler
    Sname = "aa.xlsb"
    xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*")
    If xPath = "False" Then: MsgBox "تم إلغاء العملية", vbInformation: Exit Sub
    fileName = Dir(xPath)
    If StrComp(fileName, Sname, vbTextCompare) <> 0 Then
        MsgBox "اسم الملف غير مطابق" & vbNewLine & Sname, vbCritical
        Exit Sub
    End If
    Set CrWS = Workbooks.Open(xPath)
    MsgBox " :تم  فتح الملف بنجاح" & vbNewLine & vbNewLine & CrWS.name, vbInformation
    Exit Sub
ErrHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

 

bb.xlsb

تم تعديل منذ 16 ساعات بواسطه محمد هشام.