تجميعة اكواد متجدد ان شاء الله

[الـعيدروس]

كود لمعرفة الفورم الموجودة في المصنف في رسالة

إستخدام الكود في مودويل

Sub listeUserFormClasseur()

    Dim VBCmp

    For Each VBCmp In ThisWorkbook.VBProject.VBComponents

	    If VBCmp.Type = 3 Then MsgBox VBCmp.Name

    Next VBCmp

End Sub

[الـعيدروس]

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

Sub InsertarFilas2()

Dim ii As Long, C As Range

On Error Resume Next

Set C = Application.InputBox("ضلل اسطر البيانات دون رؤس الاعمدة", Type:=8)

On Error GoTo 0

If C Is Nothing Then Exit Sub

Application.ScreenUpdating = False

With C(1)

  ii = .CurrentRegion.Rows.Count - 1: .EntireColumn.Insert

  With .Offset(1, -1).Resize(ii)

    .Value = Evaluate("row(" & .Address & ")")

  End With

  With .Offset(1 + ii, -1).Resize(ii - 1)

  .Value = Evaluate("0.5 + row(" & .Offset(-ii).Address & ")")

  End With

    .Offset(1).Resize(2 * ii - 1).EntireRow.Sort Key1:=.Offset(1, -1), Order1:=xlAscending, Header:=xlNo

  .Offset(, -1).EntireColumn.Delete

End With

Application.ScreenUpdating = True

End Sub

[الـعيدروس]

كود انشاء TextBox Activesheet

وإضافة تنسيقات عليه مثل الخط

Sub AddTextBox()

    ActiveSheet.Shapes.AddTextBox(msoTextOrientationHorizontal, 2.5, 1.5, 116, 145).TextFrame.Characters.Text = Range("a1").Value

    With Selection.Characters(Start:=1, Length:=216).Font

	    .Name = "Traditional Arabic"

	    .FontStyle = "bold"

	    .Size = 15

	    .Strikethrough = False

	    .Superscript = False

	    .Subscript = False

	    .OutlineFont = False

	   .Shadow = False

	    .Underline = xlUnderlineStyleNone

	    .ColorIndex = xlAutomatic

    End With

    Range("I15").Select

End Sub

تم تعديل مارس 21, 2012 بواسطه alidroos

[الـعيدروس]

كود إستبدال كلمة مكرره في الشيت

إلى كلمة اخرى

Sub ReplaceDemo()

Dim sht As Worksheet

For Each sht In Worksheets

    sht.Cells.Replace What:="أحبك", _

	    Replacement:="أحبك كثير", LookAt:=xlPart, MatchCase:=False

Next

End Sub

[الـعيدروس]

كود تحديد الخلايا التي فيها معادلات

لمدى متفرق

تلوين الخط

كود يستخدم في مودويل

Sub UnionDemo()

Dim MyUnion As Range

Set MyUnion = Union(Range("A1:A15"), Range("D4:E15"))

For Each cell In MyUnion

If cell.HasFormula = True Then

cell.Font.ColorIndex = 3

End If

Next cell

End Sub

[الـعيدروس]

كود إخفاء خلاياء معينه من الطباعة

بالتلاعب بالتنسيق ثم استعادة التنسيق الاصلي بعد الطباعه

يستخدم الكود في مودويل

Option Explicit

Option Base 1

Sub test()

On Error Resume Next

Dim M As Range: Set M = Range("A4:F5") ' المدى

ALI_HID_C Sheets(1), M

End Sub

Sub ALI_HID_C(ALI_SH As Worksheet, SH_A As Range)

    Dim F_ALI() As Variant

    Dim Cell As Range

    Dim i As Integer

    ReDim Preserve F_ALI(SH_A.Cells.Count)

    For Each Cell In SH_A

	    i = i + 1

		 F_ALI(i) = Cell.NumberFormat

    Next Cell

	    SH_A.NumberFormat = ";;;"

	    ورقة1.PrintPreview

	    i = 0

    For Each Cell In SH_A

	    i = i + 1

	    Cell.NumberFormat = F_ALI(i)

    Next Cell

End Sub

[الـعيدروس]

كود إلغاء دمج الخلايا

Sub UnMergeSelected()

   Selection.MergeCells = False

End Sub

تم تعديل مارس 21, 2012 بواسطه alidroos

[الـعيدروس]

كود إضافة بيانات في Combobox مباشرة من الورقة وبدون تكرار

يستخدم الكود في حدث UserForm

Private Sub UserForm_Initialize()

Dim i As Integer

For i = 1 To Sheets("ورقة1").Range("A65536").End(xlUp).Row

  ComboBox1 = Sheets("ورقة1").Range("A" & i)

  If ComboBox1.ListIndex = -1 Then ComboBox1.AddItem Sheets("ورقة1").Range("A" & i)

Next i

End Sub

[الـعيدروس]

كود تغير لون الفورم عند فتحه كل مره

استخدام الكود في حدث الفورم

Private Sub UserForm_Activate()

Application.EnableEvents = False

Dim R As Integer, B As Integer, G As Integer

R = Rnd * 255

B = Rnd * 255

G = Rnd * 255

UserForm1.BackColor = RGB(R, B, G)

Application.EnableEvents = True

End Sub

[عبدالله المجرب]

أخى العزيز / محمد

بالفعل أكواد أكثر من رائعه ، ومنتظرين المزيد

ولى طلب بسيط جداً

لقد حاولت إستخدام أحد الأكواد أعلاه وتحديداً " كود لمنع ادخال اكثر من عدد معين من الحروف "

بحيث أردت إستخدامه ليقوم الإكسيل بتنبيهى فى حالة قيامى بإدخال أكثر من رقمان بعد العلامة ولكن يبدو أن الكود أعلاه مخصص لغرض آخر.

فهل بإمكانك إفادتى عن طلبى هذا ؟

والذى يتمثل فى أن يقوم الإكسيل بتنبيهى فى حالة إدخال أكثر من رقمان بعد العلامة بمعنى فى حالة إدخالى للرقم التالى 1.23 فلا يقوم بتنبيهى ، وعلى أن يقوم بتنبيهى فى حالة الإدخال الخاطئ كــ 1.234 على سبيل المثال.

لك خالص شكرى وتقديرى

أخوك

عيد مصطفى

تفضل اخي عيد هذا تعديل للكود السابق

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    For Each cell In UsedRange

If IsNumeric(cell) Then r = cell - Int(cell)

	  If Len(r) > 4 Then

	   MsgBox " عدد الاحرف اكثر من المسموح به"

    cell.Value = ""

   End If

    Next

End Sub

[Eid Mostafa]

أخى العزيز / عبد الله

أولاً وقبل أى شئ أشكرك على سرعة تجاوبك

ولكن الكود لم يؤدى المطلوب (مرفق الملف وبه الكود) فستجد أنه حتى فى حالة إدخال رقم واحد فقط بعد العلامة

فتظهر رسالة " عدد الاحرف اكثر من المسموح به " .

وما أريدة أن يسمح الكود بإدخال حتى رقمان بعد العلامه العشريه مثل 15.23 على سبيل المثال

وألا يسمح بالزيادة عن ذلك بمعنى إن أردت إدخال القيمة التاليه مثل 15.234 فهنا تظهر الرساله.

أنا أعلم أنك على سفر ولك عذرك فى ذلك ، فقد وددت أن أفيدك بالرد ليس أكثر.

وعمره مقبوله إن شاء الله ولا تنسانا من الدعاء.

وفى إنتظار إفادة الأخوه الأعزاء

لك خالص شكرى وتقديرى

أخوك

عيد مصطفى

Desktop.rar

[محمد مصطفى ابو حمزة]

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

كود انشاء هذه الشيتات فى اى ملف عمل

Dim sMo(12) As String

sMo(1) = "يناير"

sMo(2) = "فبراير"

sMo(3) = "مارس"

sMo(4) = "ابريل"

sMo(5) = "مايو"

sMo(6) = "يونيو"

sMo(7) = "يوليو"

sMo(8) = "اغسطس"

sMo(9) = "سبتمبر"

sMo(10) = "اكتوبر"

sMo(11) = "نوفمبر"

sMo(12) = "ديسمبر"

[/center]

[right][size=5]اخي الكريم 'محمد مصطفى السلام عليكم[/size][/right]

[right][size=5]حاولت و لم اتمكن من استخدام الكود في المشاركه # 2 شيتات اشهر السنه[/size][/right]

[right][size=5]الرجاء المساعده بالشرح [/size][/right]

اخى قمت بتجربة الكود مرة اخرى وعمل بشكل جيد ضع الكود فى موديول واعمل لا زر وجرب مرة اخرى

[محمد مصطفى ابو حمزة]

أخى العزيز / محمد

بالفعل أكواد أكثر من رائعه ، ومنتظرين المزيد

ولى طلب بسيط جداً

لقد حاولت إستخدام أحد الأكواد أعلاه وتحديداً " كود لمنع ادخال اكثر من عدد معين من الحروف "

بحيث أردت إستخدامه ليقوم الإكسيل بتنبيهى فى حالة قيامى بإدخال أكثر من رقمان بعد العلامة ولكن يبدو أن الكود أعلاه مخصص لغرض آخر.

فهل بإمكانك إفادتى عن طلبى هذا ؟

والذى يتمثل فى أن يقوم الإكسيل بتنبيهى فى حالة إدخال أكثر من رقمان بعد العلامة بمعنى فى حالة إدخالى للرقم التالى 1.23 فلا يقوم بتنبيهى ، وعلى أن يقوم بتنبيهى فى حالة الإدخال الخاطئ كــ 1.234 على سبيل المثال.

لك خالص شكرى وتقديرى

أخوك

عيد مصطفى

اخى ساحاول فى ما طلبت

[محمد مصطفى ابو حمزة]

أخى العزيز / عبد الله

أولاً وقبل أى شئ أشكرك على سرعة تجاوبك

ولكن الكود لم يؤدى المطلوب (مرفق الملف وبه الكود) فستجد أنه حتى فى حالة إدخال رقم واحد فقط بعد العلامة

فتظهر رسالة " عدد الاحرف اكثر من المسموح به " .

وما أريدة أن يسمح الكود بإدخال حتى رقمان بعد العلامه العشريه مثل 15.23 على سبيل المثال

وألا يسمح بالزيادة عن ذلك بمعنى إن أردت إدخال القيمة التاليه مثل 15.234 فهنا تظهر الرساله.

أنا أعلم أنك على سفر ولك عذرك فى ذلك ، فقد وددت أن أفيدك بالرد ليس أكثر.

وعمره مقبوله إن شاء الله ولا تنسانا من الدعاء.

وفى إنتظار إفادة الأخوه الأعزاء

لك خالص شكرى وتقديرى

أخوك

عيد مصطفى

جرب المرفق اخى بعد اذن اخى عبد الله

Desktop.rar

[محمد مصطفى ابو حمزة]

شكر خاص للاستاذ عبدالله على اثراءه الموضوع

[محمد مصطفى ابو حمزة]

شكر خاص للاستاذ العيدروس على اثراءه الموضوع باكواده المتميزة

[Eid Mostafa]

^{أخى العزيز / محمد}

^{أولاً وقبل أى شئ أشكرك على سرعة تجاوبك}

^{ولكن لا زالت المشكله كما هى و فى حالة إدخال رقم واحد فقط بعد العلامة تظهر رسالة " عدد الاحرف اكثر من المسموح به " .}

^{وما أريدة أن يسمح الكود بإدخال حتى رقمان بعد العلامه العشريه مثل 15.23 على سبيل المثال}

^{وألا يسمح بالزيادة عن ذلك بمعنى إن أردت إدخال القيمة التاليه مثل 15.234 فهنا تظهر الرساله.}

^{فى إنتظار إفاداتك القيمه}

^{لك خالص شكرى وتقديرى}

^أخوك

^{عيد مصطفى}

[محمد مصطفى ابو حمزة]

^{أخى العزيز / محمد}

^{أولاً وقبل أى شئ أشكرك على سرعة تجاوبك}

^{ولكن لا زالت المشكله كما هى و فى حالة إدخال رقم واحد فقط بعد العلامة تظهر رسالة " عدد الاحرف اكثر من المسموح به " .}

^{وما أريدة أن يسمح الكود بإدخال حتى رقمان بعد العلامه العشريه مثل 15.23 على سبيل المثال}

^{وألا يسمح بالزيادة عن ذلك بمعنى إن أردت إدخال القيمة التاليه مثل 15.234 فهنا تظهر الرساله.}

^{فى إنتظار إفاداتك القيمه}

^{لك خالص شكرى وتقديرى}

^أخوك

^{عيد مصطفى}

جرب المرفق تم تطبيق الكود على المدى a1:a100 غيره كما تشاء ويتم حذف الذائد بدلا من جعل الخلية فارغة جرب واخبرنى

Desktop_2.rar

[Eid Mostafa]

^{أخى العزيز / محمد}

^{أشكرك على إفادتك القيمة ، وأعتذر عن التأخير فى الرد}

^{ولكن أخى العزيز الكود بوضعه الحالى يتحكم فى إجمالى أو فى كل ما يتم إدخاله بالخليه}

^{بمعنى أنه لايقبل أكثر من 5 أرقام بالخليه سواء قمت بإدخال 12345 أو 123.45}

^{وهو خلاف ما أقصده تماماً}

^{فما أقصده هو أن يتحكم الكود فقط فى ألا يزيد ما يتم إدخاله بعد العلامه العشريه}

^{ودون أن يتحكم مطلقاً فى عدد أرقام ماقبل العلامه}

^{بمعنى إن أردت أن أدخل 2597765.79 جنيه مصرى فيتم قبولها ودون حد أقصى للأرقام التى تدرج قبل العلامه.}

^{وبمعنى آخر أن يتحكم الكود فى الرقمان العشريان (القروش) فقط لاغير ، وألا يقبل أن يزيدا عن رقمان.}

^{أرجو ألا أكون قد أثقلت عليك}

^{فى إنتظار إفاداتك القيمه}

^{لك خالص شكرى وتقديرى}

^أخوك

^{عيد مصطفى}

[أبو ردينة]

الأخ الكريم أستاذ / محمد مصطفى

اسأل الله الكريم رب العرش العظيم أن ينفع بك و يعلمك ما ينفع و أن يجزيك عن كل مستخدم و منتفع بما تقدم ما لا عين رأت و لا أذن سمعت و لا خطر على قلب بشر - آمين

[MOHAMEDTAHER7]

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

ومن علمنى حرفا صرت لة عبدا

[محمد مصطفى ابو حمزة]

شكرا على الردود واخى عيد مصطفى مازلت احاول على طلبك

[محمد مصطفى ابو حمزة]

برنامج للفلترة المتقدمة سهل جدا وامكنانيات عديدة متوافق مع 2003 و 2007

EasyFilter 2.01.zip

[محمد مصطفى ابو حمزة]

كود الذهاب الى خلية معينة عن طريق ادخالها فى رسالة

Sub GetRange()

Dim Rng As Range

On Error Resume Next

Set Rng = Application.InputBox(prompt:="Enter range",Type:=8)

If Rng Is Nothing Then

  MsgBox "Operation Cancelled"

Else

  Rng.Select

End If

End Sub

[محمد مصطفى ابو حمزة]

كود ينسخ المدى المستخدم من كل اوراق العمل الى ورقم عمل جديدة

الماكرو الاول نسخ عادى والثانى نسخ قيم فقط

Sub CopyUsedRange()

    Dim sh As Worksheet

    Dim DestSh As Worksheet

    Dim Last As Long

    If SheetExists("Master") = True Then

	    MsgBox "The sheet Master already exist"

	    Exit Sub

    End If

    Application.ScreenUpdating = False

    Set DestSh = Worksheets.Add

    DestSh.Name = "Master"

    For Each sh In ThisWorkbook.Worksheets

	    If sh.Name <> DestSh.Name Then

		    If sh.UsedRange.Count > 1 Then

			    Last = LastRow(DestSh)

			    sh.UsedRange.Copy DestSh.Cells(Last + 1, 1)

		    End If

	    End If

    Next

    Application.ScreenUpdating = True

End Sub

Sub CopyUsedRangeValues()

    Dim sh As Worksheet

    Dim DestSh As Worksheet

    Dim Last As Long

    If SheetExists("Master") = True Then

	    MsgBox "The sheet Master already exist"

	    Exit Sub

    End If

    Application.ScreenUpdating = False

    Set DestSh = Worksheets.Add

    DestSh.Name = "Master"

    For Each sh In ThisWorkbook.Worksheets

	    If sh.Name <> DestSh.Name Then

		    If sh.UsedRange.Count > 1 Then

			    Last = LastRow(DestSh)

			    With sh.UsedRange

				    DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _

				    .Columns.Count).Value = .Value

			    End With

		    End If

	    End If

    Next

    Application.ScreenUpdating = True

End Sub

Function LastRow(sh As Worksheet)

    On Error Resume Next

    LastRow = sh.Cells.Find(What:="*", _

						    After:=sh.Range("A1"), _

						    Lookat:=xlPart, _

						    LookIn:=xlFormulas, _

						    SearchOrder:=xlByRows, _

						    SearchDirection:=xlPrevious, _

						    MatchCase:=False).Row

    On Error GoTo 0

End Function

Function Lastcol(sh As Worksheet)

    On Error Resume Next

    Lastcol = sh.Cells.Find(What:="*", _

						    After:=sh.Range("A1"), _

						    Lookat:=xlPart, _

						    LookIn:=xlFormulas, _

						    SearchOrder:=xlByColumns, _

						    SearchDirection:=xlPrevious, _

						    MatchCase:=False).Column

    On Error GoTo 0

End Function

Function SheetExists(SName As String, _

					 Optional ByVal WB As Workbook) As Boolean

	 On Error Resume Next

    If WB Is Nothing Then Set WB = ThisWorkbook

    SheetExists = CBool(Len(Sheets(SName).Name))

End Function