اذهب الي المحتوي
أوفيسنا

اضافة زر يمكننى من التنقل بين الشيتات


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

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

أخي الفاضل حفظكم الله

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

تقبل فائق الأحترام

أبو أنس ناصر حاجب

ٍٍSupporter2.rar

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

السلام عليكم

الشكر واصل للاخ ابو انس حفظه الله

كود التنقل يكفي سطر واحد


' كود التنقل بين الاوراق

Sub ShowSheetLists()

Application.CommandBars("Workbook tabs").ShowPopup

End Sub

وطلب صاحب الموضوع

في المرفق ادناه

-------------------------------------

فكرة الكود :

ان زر التنقل موجود في الورقة الرئيسية

والكود اثناء اضافة الورقة الجديدة

ينسخ الزر ويلصقه في هذه الورقة

-------------------------------------

المرفق 2003-2007

زر للتنقل.rar

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

السلام عليكم

الشكر واصل للاخ ابو انس حفظه الله

كود التنقل يكفي سطر واحد


' كود التنقل بين الاوراق

Sub ShowSheetLists()

Application.CommandBars("Workbook tabs").ShowPopup

End Sub

وطلب صاحب الموضوع

في المرفق ادناه

-------------------------------------

فكرة الكود :

ان زر التنقل موجود في الورقة الرئيسية

والكود اثناء اضافة الورقة الجديدة

ينسخ الزر ويلصقه في هذه الورقة

-------------------------------------

المرفق 2003-2007

زر للتنقل.rar

أخونا المتألق والمبدع دائماً خبور خير الغالى

تحية وتقدير لسيادتكم

لى طلب فى الكود الخاص بالتنقل بين شيتات الملف

لدى ملف به 31 شيت و جميع الشيتات مسماه بأرقام فقط من 1 إلى 31

أريد أن يتم كتابة إسم لكل شيت بالكود لكى يظهر باللستة إسم الشيت وليس رقمه المسمى به

مثلاً شيت رقم 22 يظل إسمه كما هو ( 22 ) ولكن إسمه يظهر بليست التنقل بين الشيتات بالإسم الذى أريده مثلاً ( ناجح دور ثان)

هل هذا يمكن ؟؟

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

لدى ملف به 31 شيت و جميع الشيتات مسماه بأرقام فقط من 1 إلى 31

أريد أن يتم كتابة إسم لكل شيت بالكود لكى يظهر باللستة إسم الشيت وليس رقمه المسمى به

مثلاً شيت رقم 22 يظل إسمه كما هو ( 22 ) ولكن إسمه يظهر بليست التنقل بين الشيتات بالإسم الذى أريده مثلاً ( ناجح دور ثان)

هل هذا يمكن ؟؟

جرب الكود المرفق

ارجوا ان يفي بالغرض

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

مثال.rar

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

السلام عليكم

تعديل بسيط على كود الاستاذ الحبيب الخالدي

بعد اذنه


Sub MENU_SheetLists()

Dim CB_L As Object

Dim CB_C As CommandBarControl

On Error GoTo Error1:

Application.CommandBars("MySheetList").Delete

Error1:

Set CB_L = CommandBars.Add(Name:="MySheetList", Position:=msoBarPopup)

For Each Sh In ThisWorkbook.Worksheets

    Set CB_C = Application.CommandBars("MySheetList").Controls.Add(Type:=msoControlButton)

    With CB_C

		 .Caption = Sh.CodeName: .OnAction = "GO_MySheet"

    End With

Next

Set CB_L = Nothing: Set CB_C = Nothing

Application.CommandBars("MySheetList").ShowPopup

End Sub

Sub GO_MySheet()

Sheets(Application.CommandBars.ActionControl.Index).Activate

End Sub

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

استاذنا العبقري خبور خير

كلماتك وسام من ذهب واعتز بها

وفقك الله وسدد خطاك

كود جميل من الاستاذ الخالدي

وتعديل بسيط لايذكر

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

أساتذتنا الأفاضل

الكود لا زال يقوم بعرض اسماء الشيتات كما هى باسمائها فى علامة تبويب كل ورقة

المطلوب أن يكون فى الكود سطر لكل شيت بحيث تظهر عند الضغط على الزر اسماء الشيتات كما أكتبها بالكود وليس كما هى اسمائها بعلامات التبويب

مثلاً الشيت 1 أكتب له فى الكود إسم آخر يظهر به عند الضغط على زر الأوراق

أرجو الفكرة وصلت

لكم تحياتى

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

أساتذتنا الأفاضل

الكود لا زال يقوم بعرض اسماء الشيتات كما هى باسمائها فى علامة تبويب كل ورقة

المطلوب أن يكون فى الكود سطر لكل شيت بحيث تظهر عند الضغط على الزر اسماء الشيتات كما أكتبها بالكود وليس كما هى اسمائها بعلامات التبويب

مثلاً الشيت 1 أكتب له فى الكود إسم آخر يظهر به عند الضغط على زر الأوراق

أرجو الفكرة وصلت

لكم تحياتى

اخي يوسف هل هذا ما قصدته

Option Explicit


Const mBr As String = "MySheetList"


Sub kh_AddName()

Dim Nam As Range

Dim i As Integer

Dim NamSheet As String

'''''''''''''''''''''''''''''''

On Error GoTo kh_Err

'''''''''''''''''''''''''''''''

kh_BarDelete

'''''''''''''''''''''''''''''''

Set Nam = ورقة1.Range("C3:D22")

'''''''''''''''''''''''''''''''

With Application.CommandBars.Add(Name:=mBr, Position:=msoBarPopup)

For i = 1 To Nam.Rows.Count

NamSheet = Nam.Cells(i, "A")

With .Controls.Add(Type:=msoControlButton)

.Caption = Nam.Cells(i, "B")

.OnAction = "GO_MySheet"

.Tag = NamSheet

If NamSheet = ActiveSheet.Name Then .State = -1

If IsError(Evaluate("'" & NamSheet & "'!A1")) Then

.Enabled = False

End If

End With

Next

End With

'''''''''''''''''''''''''''''''

Application.CommandBars(mBr).ShowPopup

'''''''''''''''''''''''''''''''

kh_Err:

Set Nam = Nothing

If Err Then MsgBox "Err.Number : " & Err.Number

kh_BarDelete


End Sub


Sub kh_BarDelete()

On Error Resume Next

Application.CommandBars(mBr).Delete

On Error GoTo 0

End Sub


Sub GO_MySheet()

Dim N As String

N = Application.CommandBars.ActionControl.Tag

Sheets(N).Activate

End Sub

المرفق 2003-2007

مثال اضافة اسم مخصص لاوراق العمل في بار مخصص.rar

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

الله ينور عباد باشا

بس لو ممكن ولو مافيهاش تعب لمعاليكم ولكل من يريد إثراء الموضوع

اسماء كل الشيتات التى أريد إظهارها بالكود موجودة فى أحد شيتات الملف ( الشيت رقم 31 والمسمى MyDate والذى أريده أن يظهر بالكود بإسم الصلاحيات ) بالصف الثانى من العمود الخامس E2 إلى العمود 35 AI2

هل يمكن أن يأخذ الكود اسماء الشيتات من هذا الشيت ؟؟ علماً بأنه الشيت الوحيد بين الشيتات الذى مسماه ليس رقم

والصورة المرفقة توضح أسماء الشيتات بالأرقام ومدلول الأرقام بالأسماء

86458537.jpg

Uploaded with ImageShack.us

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

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

ولكن أسماء الشيتات وأرقامها ليست بالطول ولكنها بالعرض كما أرفقت الصورة بالمشاركة السابقة

جارى محاولة تعديل الكود وسأوافيك بالنتيجة

الف شكر

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

السلام عليكم

بعد اذن استاذنا القدير خبور خير

بيكون الكود بعد التعديل هكذا


Option Explicit

Const mBr As String = "MySheetList"

Sub kh_AddName()

Dim Nam As Range

Dim i As Integer

Dim NamSheet As String

'''''''''''''''''''''''''''''''

On Error GoTo kh_Err

'''''''''''''''''''''''''''''''

kh_BarDelete

'''''''''''''''''''''''''''''''

Set Nam = ورقة1.Range("E2:AH3")

'''''''''''''''''''''''''''''''

With Application.CommandBars.Add(Name:=mBr, Position:=msoBarPopup)

    For i = 1 To Nam.Columns.Count

	    NamSheet = Nam.Cells(2, i)

	    With .Controls.Add(Type:=msoControlButton)

		    .Caption = Nam.Cells(1, i)

		    .OnAction = "GO_MySheet"

		    .Tag = NamSheet

		    If NamSheet = ActiveSheet.Name Then .State = -1

		    If IsError(Evaluate("'" & NamSheet & "'!A1")) Then

			    .Enabled = False

		    End If

	    End With

    Next

End With

'''''''''''''''''''''''''''''''

Application.CommandBars(mBr).ShowPopup

'''''''''''''''''''''''''''''''

kh_Err:

Set Nam = Nothing

If Err Then MsgBox "Err.Number : " & Err.Number

kh_BarDelete

End Sub

Sub kh_BarDelete()

On Error Resume Next

Application.CommandBars(mBr).Delete

On Error GoTo 0

End Sub

Sub GO_MySheet()

Dim N As String

N = Application.CommandBars.ActionControl.Tag

Sheets(N).Activate

End Sub

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

أخوتى الأعزاء

ذادكم الله من العلم

عندما طبقت الكود على الملف خاصتى ظهر لى إرور وتم تلوين سطر فى الكود بلون اصفر هو السطر الثالث من اسفل التالى


N = Application.CommandBars.ActionControl.Tag

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

السلام عليكم

الله يبارك فيك اخي يوسف

اعاده الله علينا وعليكم وعلى الامه الاسلاميه باليمن والبركه

استبدل السطر بهذا


N = Application.CommandBars.ActionControl.Index

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

السلام عليكم

جرب التعديل التالي

مع اضافة سطر تجاهل رسائل الخطاء


Sub GO_MySheet()

Dim N

On Error Resume Next

N = Application.CommandBars.ActionControl.Index

Sheets(N).Activate

End Sub

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

جارى التجربة أخى الغالى والملف مفتوح أمامى بالفعل

هل أضع الاسطر السابقة مكان السطر الذى يعطينى إرور ؟

أم ماذا ؟

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

لم يظبط معى ايضاً أخى الغالى

مرفق الملف والمفروض أن زر التنقل بين الصفحات فى الورقة رقم 2 فى العمود H

والكود موجود فى موديول رقم 11

وأسماء الشيتات يمكن الوصول إليها من شيت رقم 32 أو من شيت ماى ديت

وفى حالة غستخدام شيت رقم 32 يمكن إستخدام الجدول الطولى أو الجدول العرضى حسب ما يحلو لكم

اليوزر يوسف

الباس 111

تم الضغط مرتين لأن حجم الملف كان كبير

الف شكر

مجلد جديد.rar

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

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
×
×
  • اضف...

Important Information