مطلوب انشاء ورقه عمل مع الهايبر لينك من عمود محتوى على ارقام مسلسله

احمد عـــزام · مارس 21, 2018

مرفق ملف يحتوى على ثلاث صفحات

الصفحه الاولى بها عمود يحتى على ارقام من 38001 الى 38360 المطلوب عمل شيتات وتسمى بتلك الارقام مع هايبر لينك لتلك الصفحات

وتحتوى تلك الصفحات على القالب ( الصفحه الثالثه )

ولكم جزيل الشكر

STORE-ITEM -138.rar

**سليم حاصبيا** · مارس 21, 2018

جرب هذا الملف

تم تغيير اسم القالب الى Templete لحسن عمل الكود

الكود

Option Explicit

Sub Create_TOC()
    'Created By sakim On 21/3/2018
    'Macro for Create sheets with vice_versa hyprlink
    'TOC=Table Of Contents
Dim my_name$
Dim x%, i%, Sh_to_copy As Worksheet: Set Sh_to_copy = Sheets("Templete")
Dim my_sh As Worksheet: Set my_sh = Sheets("index")
Dim LrC%: LrC = my_sh.Cells(Rows.Count, 3).End(3).Row
If LrC < 4 Then LrC = 4
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For i = 4 To LrC
    my_name = Sheets(i).Name
        If my_name = "" Then
           Sh_to_copy.Copy after:=Sheets(Sheets.Count)
           With ActiveSheet
            .Name = my_sh.Range("c" & i)
            .Range("f1") = my_sh.Range("c" & i)
            .Range("f2") = my_sh.Range("d" & i)
           End With
           '=====================================
            With my_sh
                .Hyperlinks.Add .Cells(i, 2), "", _
                 SubAddress:="'" & ActiveSheet.Name & "'!A1", _
                 TextToDisplay:="go to it"
            End With
        End If
 Next
   
    Salim_button
  With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
    .ScreenUpdating = True
    End With
  my_sh.Select
End Sub

Sub Salim_button()
Dim cnt%: cnt = Sheets.Count
Dim k%
For k = 4 To cnt
    Sheets(k).Buttons.Delete
        With Sheets(k).Buttons.Add(50, 1.5, 141, 31)
            .OnAction = "My_Selection"
            .Font.Name = "Calibri"
            .Font.FontStyle = "Bold Italic"
            .Font.ColorIndex = 3
            .Characters.Text = "Go_To_Index"
        End With

    Next
End Sub
Sub My_Selection()
Sheets("index").Select
End Sub


'============================

الملف مرفق

STORE-ITEM salim.xlsm

احمد عـــزام · مارس 22, 2018

كل الشكر والتقدير للمساعده , لكن ارجوا توضيح ما اغيره حتى اتمكن من انشاء الصفحات لباقى الارقام مع الهايبر لينك

رد//////

قبل تنفيذ الكود

1-اسم القالب الى Templete

2-قم بمسح الشيتات الفارغة وتأكد ان العامود D في الشيت Index غير فارغ (ليقوم الكود بنقل التاريخ ايضاً)

3-تأكد من عدم وجود خلايا فارغة بين البيانات بالعامود C شيت Index (ذلك يؤدي الى خطأ في الكود لعدم وجود اسم للصفحة)

4- الكود يعمل حتى اخر سطر فيه بيانات بالعامود C شيت Index ابتداء من الصف الرابع

احمد عـــزام · مارس 23, 2018

جزاك الله خيرا مجهود رائع

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

مع كتابه مسلسل للاصناف المتواجده

واشكرك جدا جدا جدا

جزالك الله خيرا

STORE-ITEM salim.xlsm

**سليم حاصبيا** · مارس 23, 2018

اكتب المعادلات الضرورية في الشيت الذي سوف تنسخ عنه (قبل تنفيذ الكود) و هذه المعادلات تذهب معه اوتوماتيكياً

احمد عـــزام · مارس 23, 2018

الاستاذ الفاضل / سليم

بارك الله فيك وكل شكر على اهتمامك انا بالفعل قمت بادخال داله على الصفحه مع المرفق

ولكن انا لا اعرف كيف عمل الكود

الذى يقوم بالنسخ بالمدى الذى اريده

لا اعلم كيفيه التغير فى كل صف كيف

تم تعديل مارس 23, 2018 بواسطه احمد عـــزام

احمد عـــزام · مارس 23, 2018

انا عايز كود لعمل ذر ماكرو فى كل صفحه الخاصه برقم طلبيه على ان اقوم بادخال ماكروه به

احمد عـــزام · مارس 24, 2018

الاستاذ / سليم اعلم انى اخذت من وقتكم الكثير ارجو بمساعدتى

قمت بعمل ماكرو يحتوى على المعادله فى صفحه

template

اريد اظهار الذر فى كل الصفحات

ارجو المساعده

ومرفق الملف

STORE-ITEM salim.xlsm

3 minutes ago, احمد عـــزام said:

الاستاذ / سليم اعلم انى اخذت من وقتكم الكثير ارجو بمساعدتى

قمت بعمل ماكرو يحتوى على المعادله فى صفحه

template

اريد اظهار الذر فى كل الصفحات

اى يتم تنشيط هذا الماكرو للعمل بكل الصفحات

ارجو المساعده

ومرفق الملف

STORE-ITEM salim.xlsm

تم تعديل مارس 24, 2018 بواسطه احمد عـــزام

**سليم حاصبيا** · مارس 24, 2018

الماكرو يكتب بهذا الشكل

Sub add_formula()

 With Sheets("index")
  .Range("L4").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
End With
Sheets("Templete").Select
 With Sheets("Templete")
    .Range("D13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
    .Range("E13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,3),"""")"
    .Range("F13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,4),"""")"
    .Range("D13:F13").AutoFill Destination:=Range("D13:F200"), Type:=xlFillDefault
    End With
    Sheets("Templete").Sort.SortFields.Clear
    Sheets("Templete").Sort.SortFields.Add Key:=Range("C13"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Templete").Sort
        .SetRange Range("B13:I200")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    add_button
End Sub
'=====================

Sub add_button()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim i%
Dim k%: k = Sheets.Count
If k < 4 Then GoTo Exit_Sub
For i = 4 To k
 Sheets("templete").Select
    ActiveSheet.Shapes.Range(Array("Button 3")).Select
    Selection.Copy
    Sheets(i).Select
    ActiveSheet.Buttons.Delete
    Range("a1").Select
    ActiveSheet.Paste
    Next
Exit_Sub:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub
'=============================

الملف مرفق

STORE-ITEM salim (3).xlsm

احمد عـــزام · مارس 25, 2018

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

لقدت انتهيت بفضل الله ومن فضلكم با ما اريده لكن فوجئت عند النهايه بأن ماكرو نسخ المعادلات لايعمل الا فى صفحه

template tr'

فقط

انا رايد فى حاله مسح الخلايا بقصد ان اعيدها مره اخرى لتعدد مستخدمى البرنامج

مع اخذ فى الاعتبار بأننى قمت باضافه 150 صفحه

وتم مسح 149 ورقه لعدم القدره على التحميل

STORE-ITEM SSH2018.rar

STORE-ITEM SSH2018.xlsm

On 3/24/2018 at 6:05 AM, سليم حاصبيا said:

الماكرو يكتب بهذا الشكل


Sub add_formula()

 With Sheets("index")
  .Range("L4").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
End With
Sheets("Templete").Select
 With Sheets("Templete")
    .Range("D13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
    .Range("E13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,3),"""")"
    .Range("F13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,4),"""")"
    .Range("D13:F13").AutoFill Destination:=Range("D13:F200"), Type:=xlFillDefault
    End With
    Sheets("Templete").Sort.SortFields.Clear
    Sheets("Templete").Sort.SortFields.Add Key:=Range("C13"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Sheets("Templete").Sort
        .SetRange Range("B13:I200")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    add_button
End Sub
'=====================

Sub add_button()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim i%
Dim k%: k = Sheets.Count
If k < 4 Then GoTo Exit_Sub
For i = 4 To k
 Sheets("templete").Select
    ActiveSheet.Shapes.Range(Array("Button 3")).Select
    Selection.Copy
    Sheets(i).Select
    ActiveSheet.Buttons.Delete
    Range("a1").Select
    ActiveSheet.Paste
    Next
Exit_Sub:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

End Sub
'=============================

الملف مرفق

STORE-ITEM salim (3).xlsm

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

احمد عـــزام · مارس 25, 2018

برجاء النظر إلى اعلى

**سليم حاصبيا** · مارس 25, 2018

قم بمسح هذين السطرين من الكود

Sheets("Templete").Select
 With Sheets("Templete")

و استبدالهما بهذا


 With Activesheet

و اينما ترى

sheets("Templete")

استبدلها بـــــ

ِActivesheet

في النهاية الماكرو يهذا الشكل

Sub add_formula()

 With Sheets("index")
  .Range("L4").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
End With
'Sheets("Templete").Select
' With Sheets("Templete")
With ActiveSheet
    .Range("D13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,2),"""")"
    .Range("E13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,3),"""")"
    .Range("F13").Formula = "=IF(C13<>"""",VLOOKAnyCol(dataazzam,C13,1,4),"""")"
    .Range("D13:F13").AutoFill Destination:=Range("D13:F200"), Type:=xlFillDefault
    End With
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("C13"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("B13:I200")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    add_button
End Sub

احمد عـــزام · مارس 25, 2018

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

ممكن اتعرف على شخصكم الكريم

00201009599110

احمد عـــزام · مارس 25, 2018

اطمع فى المزيد

هل توجد امكانيه فى صفحه

index

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

حيث لاحظت ان الجهاز بطئ بسب انه توجد 155 ورقه

اطمع فى تعديله

**Ali Mohamed Ali** · مارس 25, 2018

بعد اذن استاذى سليم هل هذا هو ما تقصده؟

بمجرد كتابة الرقم فى العمود c من صفحة Index

سوف يقوم بفتح صفحة جديدة بالرقم الذى كتبته

بارك الله فيك وجزاك الله خيرا

STORE-ITEM salim (3)2.xlsm

تم تعديل مارس 25, 2018 بواسطه ali mohamed ali

احمد عـــزام · مارس 26, 2018

13 hours ago, ali mohamed ali said:

بعد اذن استاذى سليم هل هذا هو ما تقصده؟

بمجرد كتابة الرقم فى العمود c من صفحة Index

سوف يقوم بفتح صفحة جديدة بالرقم الذى كتبته

بارك الله فيك وجزاك الله خيرا

STORE-ITEM salim (3)2.xlsm

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

template

وتسمى بالرقم الذى كتبته ويكتب امام خليه رقم الطلبيه برقم الطلبيه و التاريخ

وفى نفس الوقت بصفحه الفهرس يوجد هايبر لينك للذهاب الى تلك الصفحه الا كل رقم له هايبر لينك على صفحته

**Ali Mohamed Ali** · مارس 26, 2018

تفضل أخى

STORE-ITEM salim (3)2.xlsm

احمد عـــزام · مارس 26, 2018

21 minutes ago, ali mohamed ali said:

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

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

23 minutes ago, ali mohamed ali said:

s ago, ali mohamed ali said:

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

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

**Ali Mohamed Ali** · مارس 26, 2018

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

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cont%, lr
If Target.Column = 3 Then
العمود الثالث هو المقياس
lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value
يأخذ من العمود C اسم الشيت حتى أخر صف وخلية بها بيانات
cont = Application.CountIf(Range("c:c"), Target)
جعل كل ما يكتب فى العمود C مقياس لأسماء الشيتات الجديدة التى تقوم بانشائها
If cont > 1 Or IsEmpty(Target) Then GoTo Exit_Me
Sheets("101").Copy after:=Sheets(Sheets.Count)
جعل الكود يأخذ نسخة من صفحة 101 وينسخها فى كل صفحة شيت جديد
Sheets(Sheets.Count).Name = lr
Sheets(Sheets.Count).[F4].Value = lr
تتغير الخلية F4 تلقائيا مع اسم الشيت الجديد
End If
Exit_Me:
End Sub

احمد عـــزام · مارس 26, 2018

48 minutes ago, ali mohamed ali said:

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

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cont%, lr
If Target.Column = 3 Then
العمود الثالث هو المقياس
lr = Sheets(1).Range("c" & Rows.Count).End(xlUp).Rows.Value
يأخذ من العمود C اسم الشيت حتى أخر صف وخلية بها بيانات
cont = Application.CountIf(Range("c:c"), Target)
جعل كل ما يكتب فى العمود C مقياس لأسماء الشيتات الجديدة التى تقوم بانشائها
If cont > 1 Or IsEmpty(Target) Then GoTo Exit_Me
Sheets("101").Copy after:=Sheets(Sheets.Count)
جعل الكود يأخذ نسخة من صفحة 101 وينسخها فى كل صفحة شيت جديد
Sheets(Sheets.Count).Name = lr
Sheets(Sheets.Count).[F4].Value = lr
تتغير الخلية F4 تلقائيا مع اسم الشيت الجديد
End If
Exit_Me:
End Sub

بارك الله فيك.... فين كود الهايبر لينك

**سليم حاصبيا** · مارس 26, 2018

انظر الى اخر مشاركة لي على هذا العنوان

https://www.officena.net/ib/topic/82985-فتح-شيت-جديد-بمجرد-كتابة-الإسم-فى-خلية/?tab=comments#comment-528117

تسجيل الدخول

مطلوب انشاء ورقه عمل مع الهايبر لينك من عمود محتوى على ارقام مسلسله

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

احمد عـــزام

سليم حاصبيا

احمد عـــزام

احمد عـــزام

سليم حاصبيا

احمد عـــزام

احمد عـــزام

احمد عـــزام

سليم حاصبيا

احمد عـــزام

احمد عـــزام

سليم حاصبيا

احمد عـــزام

احمد عـــزام

Ali Mohamed Ali

احمد عـــزام

Ali Mohamed Ali

احمد عـــزام

Ali Mohamed Ali

احمد عـــزام

سليم حاصبيا

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information