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

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


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

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

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

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

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

STORE-ITEM -138.rar

رابط هذا التعليق
شارك

جرب هذا الملف

تم تغيير اسم القالب الى  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

  • Like 1
رابط هذا التعليق
شارك

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

رد//////

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

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

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

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

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

 

رابط هذا التعليق
شارك

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

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

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

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

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

STORE-ITEM salim.xlsm

رابط هذا التعليق
شارك

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

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

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

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

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

 

تم تعديل بواسطه احمد عـــزام
رابط هذا التعليق
شارك

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

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

template

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

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

ومرفق الملف 

 

STORE-ITEM salim.xlsm

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

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

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

template

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

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

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

ومرفق الملف 

 

STORE-ITEM salim.xlsm

 

تم تعديل بواسطه احمد عـــزام
رابط هذا التعليق
شارك

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

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

رابط هذا التعليق
شارك

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

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

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

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

رابط هذا التعليق
شارك

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

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

 

رابط هذا التعليق
شارك

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

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

index

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

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

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

رابط هذا التعليق
شارك

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

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

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

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

 

 

STORE-ITEM salim (3)2.xlsm

تم تعديل بواسطه ali mohamed ali
  • Like 1
رابط هذا التعليق
شارك

13 hours ago, ali mohamed ali said:

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

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

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

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

 

STORE-ITEM salim (3)2.xlsm

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

template

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

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

رابط هذا التعليق
شارك

21 minutes ago, ali mohamed ali said:

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

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

 

 

23 minutes ago, ali mohamed ali said:
s 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

 

 

 

رابط هذا التعليق
شارك

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

 

 

 

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

رابط هذا التعليق
شارك

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