كود ادراج هايبر لينك الخاص بالحالة وتقريرها على حسب ترتيب الزيارة للحالة

[عادل ابوزيد]

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

الملف عبارة عن حالات كل حالة لها رقم ملف ويتم كتابة الحالة عند كل زيارة وهنا يتم رفع تقرير عند الزيارة ولابد ان يتم تسمية التقرير برقم الحالة ويتم رفعه عن طريق الاسكانر وبالتالى عند تكرار الاسم ياخذ رقم فى ملف الرفع حسب التكرار (2) أو (3) وهكذا
المطلوب 
ربط رقم الملف بالتقرير الخاص به عند الزيارة عن طريق هايبر لينك بحيث عند الضغط على رقم الحالة يظهر التقرير الخاص به فى هذه الزيارة
مثال 
الحالة رقم 60007-30 قامت بالزيارة 5 مرات المفروض عمل هايبر لينك بحيث يربط الزيارة الاولى بالتقرير الاول، والزيارة الثانية بالتقرير الثانى 
وبالمثل فى باقى الحالات

الملف الاصلى والتقارير.rar

[عادل ابوزيد]

السلام عليكم 

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

مع خالص شكرى وتقديرى

الملف بعد التعديل.xls

[محي الدين ابو البشر]

أخي الكريم عملت على الملف الأول ولم انتبه إلى تعديل الملف 

على كل جرب هذا عسى يكون المطلوب

Double Dlick على إي خلية في العمود E (رقم ملف الحالة) سوف يظهر التقرير الخاص ...

Book2.xls

[عادل ابوزيد]

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

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

وللتوضيح فقط هنا يشترط لتنفيذ الملف ان يكون بنفس الفولدر الخاص بالتقارير 

وهل يمكن ادراج رسالة بحيث عندما لا يوجد تقرير او انه تم ادراج اسم التقرير باسم الحالة بطريق الخطأ يظهر رسالة ان التقرير غير موجود ...  واذا تكرمت علينا ممكن شرح للكود وهل يمكن اضافة شروط اخرى للكود بمعنى ان الزيارة تمت والحالة انتهت ولم يخرج لها تقرير (الحالة التى لها تقرير هى الحالات التى يتم وضع علامة على الخانة التى بالعمود الصادر )

وشكر خاص للاستاذ الفاضل محمد هشام لانه لم يبخل عليا باى مساعدة وتوجيهى فى عمل الملف الثانى بعد التعديل فقط تم الاستفادة منه ايضاً زادكم الله من فضله ونعمه 

تقبلوا شكرى وتقديرى

تم تعديل ديسمبر 10, 2023 بواسطه عادل ابوزيد

[محمد هشام.]

 بعد ادن الاخ المحترم @محي الدين ابو البشر  تفضل اخي الكريم  تم الاشتغال على اخر نسخة قمت برفعها داخل المشاركة  

لتحديث ارقام الملفات قم بتشغيل الكود التالي 

Sub test()
Dim j(1 To 2) As String
Dim WSData As Worksheet: Set WSData = Sheets("البداية")
Dim R As Range:         Set R = WSData.Range("E7:E" & Range("E" & Rows.Count).End(xlUp).Row)
Dim AR() As Variant:    AR = R.Value2
Dim col() As Variant:   ReDim col(1 To UBound(AR), 1 To 1)

    j(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\"
    j(2) = Verification

    j(2) = Dir(j(1))
         If j(2) = "" Then
  ' التحقق من وجود المجلد

MsgBox "يتعدر العثور على مجلد تقرير الحالات ", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه"
    
    Else
Application.ScreenUpdating = False
Range("F7", Range("F" & Rows.Count).End(4)).ClearContents
'ترقيم الحالات المكررة
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(AR)
         If Not .Exists(AR(i, 1)) Then
            .Add AR(i, 1), 1
            col(i, 1) = AR(i, 1)
         Else
            .Item(AR(i, 1)) = .Item(AR(i, 1)) + 1
            col(i, 1) = AR(i, 1) & " (" & .Item(AR(i, 1)) & ")"
            
            End If
         Next i
    '(F) عمود
     R.Offset(, 1).Value2 = col
   End With
 End If
Application.ScreenUpdating = True
End Sub

 وفي حدث ورقة البداية ضع الكود التالي 

تم اظافة رسائل  اشعار عند التحقق من عدم وجود مجلد التقارير  او عدم وجود  رقم التقرير  مسبقا داخل المجلد 

للتجربة يمكنك اما كتابة رقم عشوائي على عمود f او تغيير اسم اي ملف داخل المجلد 😉

 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim sh As Worksheet: Set sh = Sheets("البداية")

Dim a(1 To 5) As String, FSO As Object, lastrow&
lastrow = sh.Columns("F:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1

a(1) = Application.ActiveWorkbook.Path & "\تقرير الحالات\"
a(2) = Search_File: a(3) = réf
    
    Cancel = True
    
If Not Intersect(Target, sh.Range("F7:F" & lastrow)) Is Nothing Then
    If Target.Value = "" Then Exit Sub
    
        PDFname = Target.Value: a(2) = PDFname & ".pdf"
       
        Set FSO = CreateObject("Scripting.FileSystemObject")
        
        a(3) = GetFiles(FSO, a(1), a(2)): a(4) = a(1) & Target.Value & ".pdf"
      
      ' التحقق من وجود  اسم  الملف داخل المجلد
       If a(3) = "" Then
           a(5) = " الملف رقم" & " / " & PDFname & " " & " غير موجود " _
           & Chr(10) & Chr(10) _
           & "" _

       MsgBox a(5), vbInformation, "Admin"
              Exit Sub
        End If
    If Dir(a(4)) <> vbNullString Then
        On Error Resume Next
         ActiveWorkbook.FollowHyperlink a(4)
        On Error GoTo 0
     End If
  End If
End Sub
Public Function GetFiles(ByVal FSO As Object, ByVal Search_Folder As String, ByVal Search_File As String) As String
Dim réf1 As Object, réf2 As Object, réf3 As Object
   
   If FSO.FolderExists(Search_Folder) Then
     Set réf2 = FSO.GetFolder(Search_Folder)
   For Each réf1 In réf2.Files
        If LCase(réf1.Name) = LCase(Search_File) Then
        GetFiles = réf1.Path
        Exit Function
       End If
    Next réf1
    For Each réf3 In réf2.SubFolders
             GetFiles = GetFiles(FSO, réf3.Path, Search_File)
            If GetFiles <> "" Then
           Exit Function
         End If
      Next réf3
    End If
End Function

بالتوفيق...

 

الملف بعد التعديل 2.xls

 

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

 

 

الملف الاصلى والتقارير.rar

تم تعديل ديسمبر 11, 2023 بواسطه محمد هشام.

[عادل ابوزيد]

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

مش عارف اقول ايه ابداعات من اساتذة اجلاء اكن لهم كل الحب والتقدير 

زادكم الله من فضله وكرمه ونعمه 

كل الشكر والامتنان للاستاذ الفاضل محمدهشام  ومن قبله الاستاذ محى الدين ابو البشر 

تقبلوا شكرى وتقديرى