ضبط الكود بان يعمل على اى مسار جديد

[ashhma79]

السادة الأفاضل

كل عام وانتم بخير

مطلوب ضبط الكود بان يعمل على أى مسار مختلف

فمثلا مسار البيانات الان

'C:\Users\mcc\Desktop\11111\[السابع 1-7-2025.xlsb]ملف 1'

 

فعند تغيير المسار فنجد ان الكود لا يعمل

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

 

الكود

    ActiveWorkbook.BreakLink Name:= _

        "C:\Users\mcc\Desktop\11111\ÇáÓÇÈÚ 1-7-2025.xlsb", Type:=xlExcelLinks

    Range("H9").Select

    ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select

    Application.Goto Reference:="Macro1"

 

 

Book1.xlsx

تم تعديل يوليو 7 بواسطه ashhma79

[hegazee]

جرب هذا الكود

Sub Hyperlink_cut()

    Dim selectedFile As String
    Dim result As Variant

    ' فتح مربع حوار لاختيار الملف
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "اختر ملف Excel المراد قطع الرابط معه"
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm"
        .AllowMultiSelect = False

        If .Show = -1 Then
            selectedFile = .SelectedItems(1)
        Else
            MsgBox "لم يتم اختيار ملف.", vbExclamation
            Exit Sub
        End If
    End With

    ' محاولة قطع الرابط
    On Error Resume Next
    ActiveWorkbook.BreakLink Name:=selectedFile, Type:=xlExcelLinks
    If Err.Number <> 0 Then
        MsgBox "تعذر قطع الرابط. تأكد أن الملف مرتبط فعلاً.", vbCritical
        Exit Sub
    End If
    On Error GoTo 0

    ' تحديد خلية H9
    Range("H9").Select

    ' تحديد الشكل "Rectangle 4"
    On Error Resume Next
    ActiveSheet.Shapes.Range(Array("Rectangle 4")).Select
    On Error GoTo 0

    ' الانتقال إلى المرجع "Macro1"
    On Error Resume Next
    Application.Goto Reference:="Macro1"
    On Error GoTo 0

End Sub

 

[ashhma79]

الله يبارك فيك

تمت الإجابة

[hegazee]

 جزاك الله خيرا انقر على عبارة اختر تمت الاجابة