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

**الـعيدروس** · مارس 21, 2012

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

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


Sub listeUserFormClasseur()

    Dim VBCmp

    For Each VBCmp In ThisWorkbook.VBProject.VBComponents

	    If VBCmp.Type = 3 Then MsgBox VBCmp.Name

    Next VBCmp

End Sub

**الـعيدروس** · مارس 21, 2012

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


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

**الـعيدروس** · مارس 21, 2012

كود انشاء 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

**الـعيدروس** · مارس 21, 2012

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

إلى كلمة اخرى


Sub ReplaceDemo()

Dim sht As Worksheet

For Each sht In Worksheets

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

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

Next

End Sub

**الـعيدروس** · مارس 21, 2012

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

لمدى متفرق

تلوين الخط

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


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

**الـعيدروس** · مارس 21, 2012

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

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

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


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

**الـعيدروس** · مارس 21, 2012

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


Sub UnMergeSelected()

   Selection.MergeCells = False

End Sub

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

**الـعيدروس** · مارس 21, 2012

كود إضافة بيانات في 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

**الـعيدروس** · مارس 21, 2012

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

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


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

**عبدالله المجرب** · مارس 21, 2012

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

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

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

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

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

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

والذى يتمثل فى أن يقوم الإكسيل بتنبيهى فى حالة إدخال أكثر من رقمان بعد العلامة بمعنى فى حالة إدخالى للرقم التالى 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** · مارس 21, 2012

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

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

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

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

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

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

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

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

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

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

أخوك

عيد مصطفى

Desktop.rar

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

كود انشاء هذه الشيتات فى اى ملف عمل
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]

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

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

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

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

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

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

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

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

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

أخوك

عيد مصطفى

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

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

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

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

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

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

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

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

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

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

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

أخوك

عيد مصطفى

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

Desktop.rar

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

**Eid Mostafa** · مارس 21, 2012

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

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

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

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

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

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

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

^أخوك

^{عيد مصطفى}

**محمد مصطفى ابو حمزة** · مارس 21, 2012

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

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

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

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

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

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

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

^أخوك

^{عيد مصطفى}

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

Desktop_2.rar

**Eid Mostafa** · مارس 21, 2012

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

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

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

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

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

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

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

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

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

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

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

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

^أخوك

^{عيد مصطفى}

أبو ردينة · مارس 21, 2012

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

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

MOHAMEDTAHER7 · مارس 23, 2012

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

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

**محمد مصطفى ابو حمزة** · مارس 24, 2012

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

**محمد مصطفى ابو حمزة** · مارس 24, 2012

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

EasyFilter 2.01.zip

**محمد مصطفى ابو حمزة** · مارس 24, 2012

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


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

**محمد مصطفى ابو حمزة** · مارس 24, 2012

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

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


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

تسجيل الدخول

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

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

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

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

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

انشئ حساب جديد

تسجيل دخول

محتوي مشابه

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information