جلب البيانات من أكثر من شيت بدلالة اسم الشيت

[ابو تميم]

تحية طيبة

مرفق ملف أكسل 

المطلوب بالمعادلات والكود ( طريقتين ) 

1. جلب قيمة الخلية F4 من كل ورقة إلى العمود D علما أن اسماء الأوراق ( الشيت ) هي نفسها الموجوده في العمود A في كل صف

2. عمل ارتباط تشعبي لكل شيت وذلك بالنقر على اسم الشيت في العمود A 
علما أن عدد البيانات كبير ولا يمكن الانتقال إلى كل صف وعمل ارتباط تشعبي يدويا 

مع الشكر والاحترام

جلب بيانات بدلالة اسم الشيت.rar

[الـعيدروس]

السلام عليكم

اسعد الله اوقاتك اخي ابو تميم

ان شاء الله تكون بأحسن حال

 

الكود الاول لاستخراج اسماء الاوراق عدا الورقة الحاليه

مع اضافة هيبرلينك

Sub Ali_Ad_H()
Dim W As Worksheet
r = 2
For Each W In Sheets
 If Not W.Name = ActiveSheet.Name Then
  With ActiveSheet
    .Cells(r, 1) = W.Name
    .Cells(r, 4) = W.Cells(4, 6)
    .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _
     Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name
    r = r + 1
  End With
 End If
Next W
Set W = Nothing
End Sub

 

وهذا كود اخر اخذ اسماء الاوراق حسب العمود A

Sub Ali_Ad_H1()
Dim W As Worksheet
r = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
 Set W = Sheets(CStr(Trim(Cells(i, 1))))
  With ActiveSheet
    .Cells(r, 4) = W.Cells(4, 6)
    .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _
     Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name
    r = r + 1
  End With
Next i
Set W = Nothing
End Sub

 

[ابو تميم]

أخي أبونصار

جزاك الله خيرا على هذا الكود المتميز 

 

لقد غبت كثيرا عن هذا المنتدى المتميز والمحترفين أمثالك وغيابي بسبب ظروف العمل ولكني سأعود إلى المنتدى قريبا لأتابع العلم والتعلم 

بارك الله بك 

[الـعيدروس]

عوداً حميداً اخي ابو تميم 

تقبل تحياتي وشكري

[أبو وليد]

20 ساعات مضت, الـعيدروس said:

السلام عليكم

اسعد الله اوقاتك اخي ابو تميم

ان شاء الله تكون بأحسن حال

 

الكود الاول لاستخراج اسماء الاوراق عدا الورقة الحاليه

مع اضافة هيبرلينك

Sub Ali_Ad_H()
Dim W As Worksheet
r = 2
For Each W In Sheets
 If Not W.Name = ActiveSheet.Name Then
  With ActiveSheet
    .Cells(r, 1) = W.Name
    .Cells(r, 4) = W.Cells(4, 6)
    .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _
     Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name
    r = r + 1
  End With
 End If
Next W
Set W = Nothing
End Sub

 

وهذا كود اخر اخذ اسماء الاوراق حسب العمود A

Sub Ali_Ad_H1()
Dim W As Worksheet
r = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
 Set W = Sheets(CStr(Trim(Cells(i, 1))))
  With ActiveSheet
    .Cells(r, 4) = W.Cells(4, 6)
    .Cells(r, 1).Hyperlinks.Add Anchor:=.Cells(r, 1), _
     Address:="", SubAddress:="'" & W.Name & "'!F4", TextToDisplay:=W.Name
    r = r + 1
  End With
Next i
Set W = Nothing
End Sub

 

رائع هل من الممكن أن يكون الكود لمره واحده

أي يضيف عملية الربط الى الخلايا وتكون بعد ذلك تحدث تلقائيا