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

(موضوع مميز ) بعض الاكواد المنفصلة قد تهم البعض


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

السلام عليكم

الاخوة الاعزاء حفظكم الله

هذا كود لتقييد التمرير بين صفوف والاعمدة ScrollArea

ماعدا ثنايا الصفوف التي بها بيانات زايد صف فارغ و عمود فارغ

افادني الكود في تقليص كبر حجم ملف الاكسل بالاستخدام الخاطئ

وهو استخدامي طريقة التمرير السريع بين البيانات (الكنترول + الاسهم )

عند استخدامي للاختصار اكثر الاحيان اتاري وانا في الصف 65536

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

المعذرة على الاطالة

هذا هو الكود في حدث الشيت


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim LastColumn As Integer

Dim LastRow As Long

	    If WorksheetFunction.CountA(Cells) > 0 Then

	    LastRow = Cells.Find(What:="*", After:=[A1], _

				    SearchOrder:=xlByRows, _

				    SearchDirection:=xlPrevious).Row

		 If LastRow <> 65536 Then LastRow = LastRow + 1

			    LastColumn = Cells.Find(What:="*", After:=[A1], _

				    SearchOrder:=xlByColumns, _

				    SearchDirection:=xlPrevious).Column

				 If LastColumn <> 256 Then LastColumn = LastColumn + 1

				 Me.ScrollArea = Range(Cells(1, 1), Cells(LastRow, LastColumn)).Address

    Else

				 Me.ScrollArea = ""

    End If

End Sub

تحياتي

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

هذه بعض الاكواد المميزة و المتنوعة في كيفية تثبيت CommandButton في الورقة و التي تتم غالبا في حدث Worksheet_SelectionChange

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

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

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

اخي ياريت إن امكن شرح الفائدة لكل زر امر

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

او تحتها او يمينها او يسارها وهذا جميل جدا ورائع باقي معرفة البعض الآخر مثل الثابتة او التي تتمركز في اليمين وتثبت اينما كانت

شاكراً لكم سلفاً

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

أخى الفاضل / يجيــــاوى

سلام الله عليكم

كما أنتم دائمـــا..أدام الله عليكم نعمة العلم

بعد إذنكم قمت بوضعهم جميعا فى ملف واحد

Freeze CommandButton.rar

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

ادراج زر تصغير في اليوزر فورم (Minimize)

هذا الكود في standar Module


Private Declare Function FindWindowA Lib "USER32" _

(ByVal lpClassName As String, _

ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLongA Lib "USER32" _

(ByVal hWnd As Long, _

ByVal nIndex As Long) As Long

Private Declare Function SetWindowLongA Lib "USER32" _

(ByVal hWnd As Long, _

ByVal nIndex As Long, _

ByVal dwNewLong As Long) As Long

Option Explicit

Sub FormatUserForm(UserFormCaption As String)

Dim hWnd		    As Long

Dim exLong		  As Long

    hWnd = FindWindowA(vbNullString, UserFormCaption)

    exLong = GetWindowLongA(hWnd, -16)

    If (exLong And &H20000) = 0 Then

	    SetWindowLongA hWnd, -16, exLong Or &H20000

	    Else

    End If

End Sub

هذا الكود في UserForm1Code

Private Sub UserForm_Initialize()

    Call FormatUserForm(Me.Caption)

End Sub

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

كود الاحتواء التلقائي للورقة النشطة


Public Sub AutoFitSheet()

    If ActiveWorkbook Is Nothing Then Exit Sub

    Dim i#

    If ActiveWindow.SelectedSheets.Count > 1 Then

	    For i = 1 To ActiveWindow.SelectedSheets.Count

		    ActiveWindow.SelectedSheets(i).Cells.EntireColumn.AutoFit

	    Next

    Else

	    Cells.EntireColumn.AutoFit

    End If

End Sub

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

بارك الله لك أخي محمد يحيى

موضوع رائع

واسمح لي بالمساهمة فيه ولو بالقليل

.....

كود لعرض شريط القوائم وشريط الأدوات القياسي وشريط التنسيق (الخاصين بأوفيس 2003) في أوفيس 2007 أو 2010

في الإكسل نستعمل الكود التالي


Sub show2003()

On Error Resume Next

Dim cb As CommandBar

Dim ctrl As CommandBarControl

Set cb = CommandBars.Add("Mas2003Menu")

   For Each ctrl In CommandBars("Worksheet Menu Bar").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

Set cb = CommandBars.Add("Mas2003Standard")

   For Each ctrl In CommandBars("Standard").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

Set cb = CommandBars.Add("Mas2003Formatting")

   For Each ctrl In CommandBars("Formatting").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

End Sub

وفي الوورد والباور بوينت نستعمل الكود التالي

Sub show2003()

On Error Resume Next

Dim cb As CommandBar

Dim ctrl As CommandBarControl

Set cb = CommandBars.Add("Mas2003Menu")

   For Each ctrl In CommandBars("Menu Bar").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

Set cb = CommandBars.Add("Mas2003Standard")

   For Each ctrl In CommandBars("Standard").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

Set cb = CommandBars.Add("Mas2003Formatting")

   For Each ctrl In CommandBars("Formatting").Controls

	  ctrl.Copy cb

   Next ctrl

cb.Visible = 1

End Sub

وهذا كود حذفهم جميعاً

Sub hide2003()

On Error Resume Next

CommandBars("Mas2003Menu").Delete

CommandBars("Mas2003Standard").Delete

CommandBars("Mas2003Formatting").Delete

End Sub

تحياتي للجميع

وكل عام أنتم بخير بمناسبة أفضل ايام الدنيا

عشر ذي الحجة

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

الاخوة الافاضل :

ابو الحارث

سعد عابد

محمود

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

الاستاذ الفاضل محمد صالح شكرا على الكود الجميل

اخي الحبيب ابو نصار اشكرك على الكود الجميل

=====================================

هذا ايضا كود تغيير حجم صورة بتغير قيمة خلية


Option Explicit

Option Compare Text


Public ScrWidth&, ScrHeight&

Declare Function GetSystemMetrics32 Lib "User32" _

Alias "GetSystemMetrics" (ByVal nIndex&) As Long


Sub SizePic()

    Dim SizeFactor, x

    SizeFactor = Range("A1").Value

    ActiveSheet.Shapes(1).Width = SizeFactor * (GetSystemMetrics32(0))

End Sub

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

كود لتثبيت وظيفة اضافية

بفرض ان الملف هو MyAddIn.xla و ان مسار الملف هو C:\MyAddIn.xla


Sub InstallAddIn()

	    Dim AI As Excel.AddIn

	    Set AI = Application.AddIns.Add(Filename:="C:\MyAddIn.xla")

	    AI.Installed = True

End Sub

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

كود لتثبيت وظيفة اضافية

بفرض ان الملف هو MyAddIn.xla و ان مسار الملف هو C:\MyAddIn.xla


Sub InstallAddIn()

		Dim AI As Excel.AddIn

		Set AI = Application.AddIns.Add(Filename:="C:\MyAddIn.xla")

		AI.Installed = True

End Sub

بارك الله فيك أخي محمد يحياوي وهذا هو الكود العكسي إلغاء تثبيت وظيفة إضافية

sub UnInstall_Addin()

Dim oXLAddin As AddIn

For Each oXLAddin In Application.AddIns

If oXLAddin.FullName = "C:\MyAddIn.xla" Then

oXLAddin.Installed = False

End If

Next oXLAddin

End Sub

وكل عام أنتم بخير

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

الاخوة الافاضل

سعد عابد

جمال دغيدي

شكرا جزيلا

الاخ الفاضل محمد صالح شكرا على الكود الجميل

==============================================

كود انشاء ملف وورد و تصدير بيانات اليه

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

استدعاء بيانات من جدول قاعدة بيانات

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

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

Sub deletshape()

Dim sh As Shape



For Each sh In activesheet.Shapes


If sh.Type = msoPicture Then

sh.Delete

End If

Next sh


End Sub

حذف جميع الصور الموجودة فى الصفحة النشطة

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

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

فهرس 3 من موضوع الاكواد المنفصلة.rar

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

تريد ان تبحث عن كلمة او نص في خلية في ورقة او في جميع اوراق المصنف ...

تحصل على جميع نتائج البحث في ورقة جديدة مع جميع ارتباطات الخلايا محل البحث

zip.gif بحث عن.rar 19.41K 31 عدد مرات التحميل

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

دكتور محمد صلاح

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



Sub change_sheet_tab_color()

ActiveWorkbook.Sheets(1).Tab.ColorIndex = 0

ActiveWorkbook.Sheets(2).Tab.ColorIndex = 1

ActiveWorkbook.Sheets(3).Tab.ColorIndex = 2

ActiveWorkbook.Sheets(3).Tab.ColorIndex = 3

ActiveWorkbook.Sheets(4).Tab.ColorIndex = 4

End Sub

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

غير فى أرقام الألوان ولاحظ

ملحوظة : يجب أن يكون الكود مناسبا للعدد الأوراق

كود تلوين تبويبات الأوراق.rar

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

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information