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

[الـعيدروس]

السلام عليكم

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

هذا كود لتقييد التمرير بين صفوف والاعمدة 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

Freeze CommandButton1.rar

Freeze CommandButton2.rar

Freeze CommandButton3.rar

Freeze CommandButton4.rar

Freeze CommandButton5.rar

Freeze CommandButton6.rar

Freeze CommandButton7.rar

Freeze CommandButton8.rar

Freeze CommandButton9.rar

[KHMB]

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

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

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

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

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

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

[محمد يحياوي]

الاخ الكريم يمكنك اضافة اي رقم الى كلمتي (Top - Left) مثلا +20 او +40 و لاحظ الفرق

[دغيدى]

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

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

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

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

Freeze CommandButton.rar

[محمد يحياوي]

ادراج زر تصغير في اليوزر فورم (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

Add Minimize Button To Userform.zip

[محمد يحياوي]

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

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

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

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

عشر ذي الحجة

[الـعيدروس]

وهذا كود تغير اسم الورقة النشطة

Sub Renamed_SH()

alidroos_sh = Application.Dialogs(xlDialogWorkbookName).Show

End Sub

[محمد يحياوي]

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

ابو الحارث

سعد عابد

محمود

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

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

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

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

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

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

تغيير حجم صورة حسب تغير قيمة خلية.rar

[محمد يحياوي]

كود مراجعة الصيغة في الخلية المحدة

مراجعة الصيغ تحديد الخلايا.zip

[محمد يحياوي]

بعض الدوال المهمة للرجوع الى ورقة عمل عن طريق الصيغ

الرجوع إلى ورقة عمل من الصيغ.rar

[محمد يحياوي]

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

بفرض ان الملف هو 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

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

[محمد يحياوي]

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

سعد عابد

جمال دغيدي

شكرا جزيلا

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

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

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

تصدير بيانات الى وورد.rar

[محمد يحياوي]

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

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

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

[دغيدى]

Sub open_Calculator_by_vba()

Shell ("calc")

End Sub

كود لاظهار الآلة الحاسبة

[دغيدى]

Sub open_notepad_by_vba()

Shell ("notepad")

End Sub

كود لاظهار النوت باد notepad

[دغيدى]

وهذا الكود لفتح control panel

Sub open_control_panel_by_vba()

Shell ("control panel")

End Sub

تم تعديل نوفمبر 11, 2011 بواسطه دغيدى

[دغيدى]

إدراج صف فارغ عند تغيير البيانات في عمود

منقول

إدراج صف فارغ.rar

[دغيدى]

لمعرفة عدد ايام شهر محدد ( معين )

=DAY(DATE(YEAR(A2);MONTH(A2)+1;DAY(1))-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

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

تم تعديل نوفمبر 11, 2011 بواسطه دغيدى

[محمد يحياوي]

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

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

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

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

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

بحث عن.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