اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر (معدل)

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

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

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

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

'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

تم تعديل بواسطه 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

قام بنشر

جرب هذا الكود

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

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information