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

[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

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

[ashhma79]

بارك الله فيك اخى الغالى

 

مطلوب بعد فتح مستند  aa

 نسخ  sheet1

 الى مستند bb

ثم غلق مستند aa

ترحيل.rar

تم تعديل منذ 11 ساعات بواسطه ashhma79

[محمد هشام.]

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

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

Option Explicit
Sub GetData()
    On Error GoTo EndClear
    Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long
    Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String
    
    ColArr = Split("1 2 3 4"): SetApp False
    
    Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb"
    If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit
    
    Set WS = Workbooks.Open(xPath)
    Set CrWS = WS.Sheets("Sheet1")
    
    If IsEmpty(dest.Cells(1, 1)) Then
    For i = 0 To UBound(ColArr)
        dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value
       Next i
    End If

    début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1
    If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit
    tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1
    
    For i = 0 To UBound(ColArr)
    dest.Cells(tbl2, i + 1).Resize(tmp).Value = _
        CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value
    Next i
    
    Application.Goto dest.Range("A1"), True
CleanExit:
    If Not WS Is Nothing Then WS.Close False
    SetApp True
    If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation
    Exit Sub
EndClear:
    Resume CleanExit
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    With Application
        .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable
        .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

 

ترحيل v2.rar