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

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

طريقتين لحذف جميع البيانات بدون المعادلات

لطريقة الاولى

اضغط F5

يظهر الشكل التالى

اختر SPECIAL

ليظهر الشكل التالى

اختر CONSTANts

وتاكد ان علامات الصح تحت FORMULAS موجودة بالكامل

ثم اضغط على OK

ثم DEL من الكيبورد

الطريقة الثانية

عن طريق هذا الكود

Sub ClearAllButFormulas()

Dim wks As Worksheet

For Each wks In Worksheets

'iلتفادى الخطأ فى حالة وجود معادلات فقط

On Error Resume Next

wks.Cells.SpecialCells _

(xlCellTypeConstants, 23).ClearContents

On Error GoTo 0

End Sub

كود لتكبير الخلية النشطة فقط

المرفقات :

Book1.rar 9.95K 27 عدد مرات التحميل

كود جعل الاكسيل نسخة demo بوقت محدد

Sub Auto_Open()

    Dim exdate As Date

    exdate = "04/30/2011"

    If Date > exdate Then

		    MsgBox ("لقد استخدمت البرنامج للمدة القصوى =منتدى اوفيسنا")

		    ActiveWorkbook.Close

    End If

    MsgBox ("تبقى لك " & exdate - Date & "Days left")

End Sub

ماكرو للوصول لخلية الادخال الجديدة باختصار كيبورد ماكرو للوصول لخلية الادخال الجديدة باختصار كيبورد كل ما عليك الضغط على ctrl+j او اى اختصار تحدده او وضع زر المرفقات :

Book1.rar 9.23K 14 تجميع لاختصارات الكيبورد المرفقات :

ExcelShortcuts_all.rar 7.45K 20 عدد مرات التحميل

كود لمنع ادخال اكثر من عدد معين من الحروف كود لمنع ادخال اكثر من عدد معين من الحروف

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    For Each cell In UsedRange

'تدخل عدد الاحرف بعد علامة <

		    If Len(cell.Value) > 15 Then

				    MsgBox " عدد الاحرف اكثر من المسموح به __منتدى اوفيسنا___"

				    cell.Value = ""

		    End If

    Next

End Sub

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

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

	    Dim rng As Range

	    Dim rCell As Range

	    Dim iChars As Integer

	    On Error GoTo ErrHandler

   'Change these as desired

'لكتابة عدد الاحرف

	    iChars = 15

'لكتابة المدى المراد استخدامه (منتدى اوفيسنا)

	    Set rng = Me.Range("A1:A10")

	    If Not Intersect(Target, rng) Is Nothing Then

			    Application.EnableEvents = False

			    For Each rCell In Intersect(Target, rng)

					    If Len(rCell.Value) > iChars Then

							    rCell.Value = Left(rCell.Value, iChars)

							    MsgBox rCell.Address & " has more than" _

								  & iChars & " characters." & vbCrLf _

								  & "It has been truncated."

					    End If

			    Next

	    End If

ExitHandler:

	    Application.EnableEvents = True

	    Set rCell = Nothing

	    Set rng = Nothing

	    Exit Sub

ErrHandler:

	    MsgBox Err.Description

	    Resume ExitHandler

End Sub

يصعب الوصول الى او مسح الاسماء التى لم يعد لها اى استخدام مع هذا البرنامج التحكم سهل جداً منقول من منتدى اجنبى المرفقات :

[*]

namemanager2007.zip 950.63K 4 عدد مرات التحميل كود لمسح اسماء المدى الغير مستخدمة

Sub RidOfNames()

	    Dim myName As Name

	    Dim fdMsg As String

	    On Error Resume Next

	    fdMsg = ""

	    For Each myName In Names

			    If Cells.Find(What:=myName.Name, _

				  After:=ActiveCell, _

				  LookIn:=xlFormulas, _

				  LookAt:=xlPart, _

				  SearchOrder:=xlByRows, _

				  SearchDirection:=xlNext, _

				  MatchCase:=False, _

				  SearchFormat:=False).Activate = False Then

					    fdMsg = fdMsg & myName.Name & vbCr

					    ActiveWorkbook.Names(myName.Name).Delete

			    End If

	    Next myName

	    If fdMsg = "" Then

			    MsgBox "لايوجد اسماء فى هذا المصنف---- منتدى اوفيسنا-----"

	    Else

			    MsgBox "Names Deleted:" & vbCr & fdMsg

	    End If

End Sub

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

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

For Each r In ActiveWindow.RangeSelection.Rows

	r.RowHeight = 36

Next r

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

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

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

Sub officenaDoMonths()

	Dim J As Integer

	Dim K As Integer

	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) = "ديسمبر"

	For J = 1 To 12

		If J <= Sheets.Count Then

			If Left(Sheets(J).Name, 5) = "Sheet" Then

				Sheets(J).Name = sMo(J)

			Else

				Sheets.Add.Move after:=Sheets(Sheets.Count)

				ActiveSheet.Name = sMo(J)

			End If

		Else

			Sheets.Add.Move after:=Sheets(Sheets.Count)

			ActiveSheet.Name = sMo(J)

		End If

	Next J

	For J = 1 To 12

		If Sheets(J).Name <> sMo(J) Then

			For K = J + 1 To Sheets.Count

				If Sheets(K).Name = sMo(J) Then

					Sheets(K).Move Before:=Sheets(J)

				End If

			Next K

		End If

	Next J

	Sheets(1).Activate

End Sub

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

كود حماية الخلايا بعد الادخال

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim MyRange As Range

    Set MyRange = Intersect(Range("A1:D100"), Target)

    If Not MyRange Is Nothing Then

	    Sheets("Sheet1").Unprotect password:="hello"

	    MyRange.Locked = True

	    Sheets("Sheet1").Protect password:="hello"

    End If

End Sub

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

أحسنت اخي محمد

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

عندما تقوم بحماية ااورقة تترك للمستخدم بعض الخلايا القليلة فقط الغير محمية وذلك للادخال

ولكن التنقل يكون على كل الخلايا

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

Private Sub Worksheet_Change(ByVal Target As Range)

	Application.EnableEvents = False

	If Target.Address = "$C$10" Then Range("D5").Select

	If Target.Address = "$D$10" Then Range("E5").Select

	Application.EnableEvents = True

End Sub

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

شكرا لك اخى عبد الله

كود اخر اكثر تحكما فى موضوع التنقل بين الخلايا

Private Sub Worksheet_Open(ByVal Target As Range)


	Dim aTabOrd As Variant

	Dim i As Long


	 'ضع ترتيب الخلايا للتنقل بينها

	aTabOrd = Array("D1", "U1", "AG1", "E3", "E6", "E7", "E8", "E9", "C10", "Q10", _

	"D11", "Q11", "D12", "Y6", "Y7", "Y8", "Y9", "W10", "AK10", "X11", "AK11", "X12", _

	"E13", "Q13", "Z13", "AG13", "D14", "Q14", "AG14", "F15", "O15", "AA15", "AI15", _

	"E16", "M16", "S16", "AA16", "AI16", "C17", "G17", "N17", "D18", "E19", "C20", "E21", _

	"G22", "P22", "F23", "A24", "A25", "A26", "A27", "A28", "A29", "AD19", "S20", "U20", "AD20", _

	"S21", "U21", "AD21", "S22", "U22", "AD22", "S23", "U23", "AD23", "S24", "U24", "AD24", "S25", _

	"U25", "AD25", "S27", "U27", "AD27", "S28", "U28", "AD28", "S29", "U29", "AD29", "AI32", _

	"AF35", "C31", "L31", "C32", "N32", "F34", "D35", "G36", "G37", "D38", "F50", "T40", "AI40", _

	"AI42", "AI43", "AI44", "AI45", "AI47", "AI48", "AI49", "AI50")


	 'Loop through the array of cell address

	For i = LBound(aTabOrd) To UBound(aTabOrd)

		 'لو تغيرت خلية فى النطاق المعرف سابقا

		If aTabOrd(i) = Target.Address(0, 0) Then

			 'لو الخلية التى تغيرت هى اخر خلية

			If i = UBound(aTabOrd) Then

				 'اختر اول خلية فى النطاق

				Me.Range(aTabOrd(LBound(aTabOrd))).Select

			Else

				 'اختر الخلية التالية (مندى اوفيسسنا)

				Me.Range(aTabOrd(i + 1)).Select

			End If

		End If

	Next i


End Sub

تم التصحيح فى المشاركة رقم 10

**احمد غانم** · مارس 20, 2012

لا يسعنا امام هذا السيل من الإبداع الا التقدير العالي و الدعاء بدوام التوفيق و النجاح

بارك الله جهودك

تم تعديل مارس 20, 2012 بواسطه aghanem

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

شكرا لك اخى عل التشجيع

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

اسف اخوانى هناك خطأ عند تجربة الكود السابق وهذا تصحيحه

Dim aTabOrd As Variant

Dim iTab    As Long

Dim nTab    As Long


Private Sub Worksheet_SelectionChange(ByVal Target As Range)


    If IsEmpty(aTabOrd) Then

	    aTabOrd = Array("D1", "U1", "AG1", "E3", "E6", "E7", "E8", "E9", "C10", "Q10", _

	    "D11", "Q11", "D12", "Y6", "Y7", "Y8", "Y9", "W10", "AK10", "X11", "AK11", "X12", _

	    "E13", "Q13", "Z13", "AG13", "D14", "Q14", "AG14", "F15", "O15", "AA15", "AI15", _

	    "E16", "M16", "S16", "AA16", "AI16", "C17", "G17", "N17", "D18", "E19", "C20", "E21", _

	    "G22", "P22", "F23", "A24", "A25", "A26", "A27", "A28", "A29", "AD19", "S20", "U20", "AD20", _

	    "S21", "U21", "AD21", "S22", "U22", "AD22", "S23", "U23", "AD23", "S24", "U24", "AD24", "S25", _

	    "U25", "AD25", "S27", "U27", "AD27", "S28", "U28", "AD28", "S29", "U29", "AD29", "AI32", _

	    "AF35", "C31", "L31", "C32", "N32", "F34", "D35", "G36", "G37", "D38", "F50", "T40", "AI40", _

	    "AI42", "AI43", "AI44", "AI45", "AI47", "AI48", "AI49", "AI50")

	    nTab = UBound(aTabOrd) + 1

	    iTab = 0

    Else

	    iTab = (iTab + 1) Mod nTab

    End If


    Application.EnableEvents = False

    Range(aTabOrd(iTab)).Select

    Application.EnableEvents = True


End Sub

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

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

وقد يغيرها المستخدم فيضيع كل شىء

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

ActiveWorkbook.Protect Password:="MyPassword", Structure:=True

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

كود لاظهار هل الورقة محمية ام لا وهل الملف بالكامل محمى ام لا

وهو على شكل معادلة نضعها فى اى خلية

protected.rar

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

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

وان اراد احد الاساتذة شرح الباقى فله الجزاء

COLOR.rar

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

دالة لضبط اول حرف وجعله capital

title.rar

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

قائمة بالدوال الجديدة فى 2007

http://blogs.office.com/b/microsoft-excel/archive/2005/10/20/formula-editing-improvements-part-3-new-functions.aspx

elsedik · مارس 20, 2012

اخى الفاضل محمد اية الابداع دة بجد شغال عالى جدا الى الامام بالتوفيق دائما

اخوك الصديق

ابو تميم · مارس 20, 2012

جزاك الله خيرا أخي محمد

إلى الأمام إن شاء الله

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

في 20‏/3‏/2012 at 14:53, elsedik said:

اخى الفاضل محمد اية الابداع دة بجد شغال عالى جدا الى الامام بالتوفيق دائما

اخوك الصديق

في 20‏/3‏/2012 at 15:01, ابو تميم said:

جزاك الله خيرا أخي محمد

إلى الأمام إن شاء الله

شكرا لكم اخوتى على الرد المُشجع

hesham_khadr200 · مارس 20, 2012

بارك الله فيك

**saad abed** · مارس 20, 2012

اخى محمد

جزاك الله خيرا

مجهود كبير بارك الله فيك

سعد عابد

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

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

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

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

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

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

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

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

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

أخوك

عيد مصطفى

**احمد غانم** · مارس 20, 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

السلام عليكم

جزاك الله خير اخ محمد مصطفى

موضوع جميل جدا

بعد اذنك

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

استخدامه من مودويل

Sub A()

ThisWorkbook.VBProject.VBComponents("UserForm1").Properties("backcolor") = RGB(255, 125, 125)

End Sub

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

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

يوفر وقت النقر كليك على الخلية :wink2:

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

Private Sub Worksheet_Change(ByVal Target As Range)

Set r = [a2:a100]: Set r1 = [b2:b100]

If Not Intersect(Target, r) Is Nothing Then

With Application

    .Goto Target.Offset(, 1)

    .SendKeys ("%{DOWN}")

End With

ElseIf Not Intersect(Target, r1) Is Nothing Then

Target.Offset(1, -1).Select

End If

End Sub

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

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

وتفاصيل اخرى للتعليقات أكتشفها بنفسك

Sub ShowCommentsAllSheets()

  Application.ScreenUpdating = False

  Dim commrange As Range

  Dim mycell As Range

  Dim ws As Worksheet

  Dim newwks As Worksheet

  Dim i As Long

Set newwks = Worksheets.Add

newwks.Range("A1:E1").Value = Array("Sheet", "Address", "Name", "Value", "Comment")

For Each ws In ActiveWorkbook.Worksheets

  On Error Resume Next

  Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)

  On Error GoTo 0

  If commrange Is Nothing Then

  Else

    i = newwks.Cells(Rows.Count, 1).End(xlUp).Row

    For Each mycell In commrange

	   With newwks

		 i = i + 1

		 On Error Resume Next

		 .Cells(i, 1).Value = ws.Name

		 .Cells(i, 2).Value = mycell.Address

		 .Cells(i, 3).Value = mycell.Name.Name

		 .Cells(i, 4).Value = mycell.Value

		 .Cells(i, 5).Value = mycell.Comment.Text

	   End With

    Next mycell

  End If

  Set commrange = Nothing

Next ws

newwks.Cells.WrapText = False

newwks.Columns("E:E").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart, _

  SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Application.ScreenUpdating = True

End Sub

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

تسجيل الدخول

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

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

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

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

Join the conversation

محتوي مشابه

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

Important Information