الاستاذ مجدى
عزيزي الزائر / عزيزتي الزائرة يرجي التكرم بتسجبل الدخول اذا كنت عضو معنا
او التسجيل ان لم تكن عضو وترغب في الانضمام الي اسرة المنتدي
سنتشرف بتسجيلك
شكرا
ادارة المنتدي







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


شاطر | 
 

 بعض الاكواد المنفصلة للفجوال بيزك للاكسل

اذهب الى الأسفل 
كاتب الموضوعرسالة
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الجمعة فبراير 10, 2017 4:55 am

بعض الاكواد المنفصلة للفجوال بيزك للاكسل


كود صندوق حوار يظهر عند فتح الملف

Private Sub Workbook_Open()

MsgBox ("توضع هنا العبارة التى تريد أن تظهرها عند فتح الملف مع تحيات مجدى يونس")

End Sub

توليد ارقام عشوائية

Sub Random()
Dim myRange As Range
Set myRange = Worksheets("æÑÞÉ1").Range("A1:D5")
myRange.Formula = "=int(RAND()*101)"
myRange.Font.Bold = True
End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الجمعة فبراير 10, 2017 9:55 pm

منع اضافة اوراق جديدة

Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.DisplayAlerts = False
MsgBox "عفوا, لايمكنك اضافة اوراق اخرى", _
vbInformation
Sh.Delete
Application.DisplayAlerts = True
End Sub

حماية ورقة بزر اختيار

Sub yahProtectSheet_Click()
If Sheets("yah").CheckBoxes("Check Box 3").Value = xlOn Then
ActiveSheet.Protect DrawingObjects:=True, Contents:=True
Else
ActiveSheet.Unprotect
End If
End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الجمعة فبراير 10, 2017 10:01 pm

منع الطباعة في بعض الاوراق

Private Sub workbook_BeforePrint(Cancel As Boolean)
Select Case ActiveSheet.Name
Case "ورقة1", "ورقة2"
Cancel = True
MsgBox "عفوا, لايمكنك الطباعة", _
vbInformation
End Select
End Sub

ربط لبل بخلية

Private Sub UserForm_Activate()
Label1.Caption = Range("G4").Value
End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الجمعة فبراير 10, 2017 10:18 pm

كود لالتقاط صورة للشاشة

Sub PrintTheScreen()

Application.SendKeys "(%{1068})"

DoEvents

End Sub

كود لاظهار الرسام

Sub kh_mspaint()

Dim ReturnValue

ReturnValue = Shell("c:\windows\system32\mspaint.exe", 3)

End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأربعاء فبراير 15, 2017 9:11 pm

لجعل ال textbox في الفورم يقرب القيمه التي بداخله

لاقرب رقمين عشرين

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Format(TextBox1, "#.00")
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox2 = Format(TextBox2, "#.00")
End Sub

Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox13 = Format(TextBox3, "#.00")
End Sub


_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأربعاء فبراير 15, 2017 9:18 pm

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

Private Sub TextBox1_AfterUpdate()
TextBox1.Text = Format(TextBox1.Text, "0.0")
End Sub

هنا نوع التنسيق "0.0" يكون رقم واحد بعد العلامه العشريه
مثال لو حضرتك ادخلت 20 فقط ستجد التكست بوكس اصبح 20.0

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأربعاء فبراير 15, 2017 9:22 pm

ادخلت رقمين عشريين او لم تدخل ارقام عشريه ستجد النتيجة بعد رقم عشرى واحد
طيب لو احنا عايزين رقمين بعد العلامه العشريه الموضوع بسيط جدا هنخلى التنسيق كالتالى "0.00"
شاهد الكود

Private Sub TextBox1_AfterUpdate()
TextBox1.Text = Format(TextBox1.Text, "0.00")
End Sub

طيب لو 3 أرقام عشريه
Private Sub TextBox1_AfterUpdate()
TextBox1.Text = Format(TextBox1.Text, "0.000")
End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأحد فبراير 19, 2017 8:31 am

الاشارة للعمود للصفحة النشطة
Private Sub TextBox2_Change()
Range("a1:a50000")
If TextBox2.Value <> "" Then
ks = WorksheetFunction.CountA(Range("a1:a50000"))
TextBox1.Value = ks
Else
TextBox1.Value = ""
End If
End Sub

الاشارة للعموود لصفحة معينة
Private Sub TextBox2_Change()
Sheets("Sheet1").Range("a1:a50000")
If TextBox2.Value <> "" Then
ks = WorksheetFunction.CountA(Range("a1:a50000"))
TextBox1.Value = ks
Else
TextBox1.Value = ""
End If
End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأحد فبراير 19, 2017 5:17 pm

دالة بسيطة للفرق بين تاريخين بالطريقة المتبعة عندنا في مصر (وبها بعض الاختلاف عن datedif الموجودة في الإكسل)

حيث يتم حساب السن عندنا بطرح أيام التاريخ الأحدث - أيام التاريخ الأقدم وإذا كان الناتج بالسالب يتم استلاف شهر (30 يوم كقاعدة ثابتة)

ونفس الكلام مع الشهور مع استلاف 12 شهر في حالة شهور التاريخ الأحدث أقل من شهور التاريخ القديم

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


Function date_diff(oldd As Date, newd As Date) As String

Dim years, months, days As Integer

years = Year(newd) - Year(oldd)

If Month(newd) < Month(oldd) Then

years = years - 1

months = (Month(newd) + 12) - Month(oldd)

Else

months = Month(newd) - Month(oldd)

End If

If Day(newd) < Day(oldd) Then

months = months - 1

days = (Day(newd) + 30) - Day(oldd)

Else

days = Day(newd) - Day(oldd)

End If

date_diff = Format(years, "00") & " عام و " & Format(months, "00") & " شهر و " & Format(days, "00") & " يوم"

End Function


_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأربعاء فبراير 22, 2017 7:02 pm

ظهور اليوزر فورم بدون الفريم الازرق الى من الاعلى الى به علامة الغلق

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long _
, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub UserForm_Initialize()

Dim hWnd As Long, Style As Long
hWnd = FindWindow(vbNullString, Me.Caption)
Style = GetWindowLong(hWnd, -16) And Not &HC00000
SetWindowLong hWnd, -16, Style
DrawMenuBar hWnd
End Sub


منع استخدام علامة الغلق

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

Cancel = True

End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
فوازنور6



عدد المساهمات : 1
تاريخ التسجيل : 17/03/2017

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   السبت مارس 18, 2017 7:00 pm

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

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الأحد مارس 19, 2017 4:42 pm

الف شكر

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
محمود عبيد



عدد المساهمات : 8
تاريخ التسجيل : 02/04/2017

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   السبت أبريل 29, 2017 3:33 am

شكرا موضوع حميل
الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الثلاثاء أكتوبر 03, 2017 11:19 am

كود لعمل باسورد حماية لكافة اوراق الملف
Option Explicit

Sub ProtectAllSheets()

Dim pwd As String, pwd2 As String

Dim ws As Worksheet

Do

pwd = Application.InputBox("ادخل الباسورد?", "عمل باسورد للصفحات", Type:=2)

If pwd = "False" Then Exit Sub

pwd2 = Application.InputBox("اعد ادخال الباسورد للتأكيد ?", "التأكد من الباسورد", Type:=2)

If pwd2 = "False" Then Exit Sub

If pwd = pwd2 Then Exit Do Else MsgBox "عفـواً الباسور غير مطابق"

Loop

For Each ws In Worksheets

ws.Protect Password:=pwd

Next ws

End Sub



وهذا الغاء باسورد الحمايه

Option Explicit

Sub UnProtectAllSheets()

Dim pwd As String, ws As Worksheet

On Error Resume Next

pwd = Application.InputBox("الرجاء ادخال الباسورد لاالغاء الحمايه عن كافة الاوراق?", "الغاء الحماية", Type:=2)

If pwd = "False" Then Exit Sub

For Each ws In Worksheets

ws.Unprotect Password:=pwd

If ws.ProtectContents = True Then

MsgBox "الباسورد غير صحيح لم يتم الغاء الحماية"

Exit Sub

End If

Next ws

End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الثلاثاء أكتوبر 03, 2017 11:21 am

كود لعمل اوراق جديد بحسب ماتكتبه في

العمود A من السطر الثاني كم تشاء من الاوراق

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

الورقه الرئيسية

Option Explicit

Sub CreateSheets()

Dim RNG As Range

Dim c As Range

Application.ScreenUpdating = False

Set RNG = ActiveSheet.Range("A2:A" & Rows.Count).SpecialCells(xlConstants)

For Each c In RNG

If Not Evaluate("ISREF('" & c.Text & "'!A1)") Then

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Text

Else

Sheets(c.Text).Move After:=Sheets(Sheets.Count)

End If

Sheets(c.Text).Range("A1").Formula = "=HYPERLINK(""#ورقة1!A1"",""الرئيسية"")"

c.Offset(, 1).FormulaR1C1 = "=HYPERLINK(""#'"" & RC[-1] & ""'!A1"", ""Link"")"

Next c

RNG.Parent.Activate

Application.ScreenUpdating = True

End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
مجدى يونس
Admin
avatar

عدد المساهمات : 976
تاريخ التسجيل : 22/02/2013
العمر : 63

مُساهمةموضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل   الثلاثاء أكتوبر 03, 2017 11:29 am

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

واذا تعدت المحاولات 3 مرات يقفل الملف

Public ABU_NSSAR As Byte

Private Sub CommandButton1_Click()

الباسورد = "123"

ِABOOD = InputBox("إدخل الباسورد لتنفيذ الماكرو")

If ِABOOD <> الباسورد Then

MsgBox ("الباسورد خطاء (الإدخال الخاطئ اكثر من 3 محاولات يقفل البرنامج)")

ABU_NSSAR = ABU_NSSAR + 1

If ABU_NSSAR > 3 Then

 Application.DisplayAlerts = False

 Application.Quit

End If

Exit Sub

End If

Range("a3").Value = "مع تحيات مجدى يونس"

MsgBox ("تم تنفيذ الماكرو")

End Sub

_________________
عندما تولد يابن ادم يؤذن فى أذنك من غير صلاة وعندما تموت يصلى عليك من غير أذان وكأن حياتك فى الدنيا ليست سوى الوقت الذى تقضيه بين الأذان والصلاة فلا تقضيهما فيما لاينفع
---((الله ناظرى الله سامعى الله مطلع علي))-

الرجوع الى أعلى الصفحة اذهب الى الأسفل
معاينة صفحة البيانات الشخصي للعضو http://magdi54.forumegypt.net
 
بعض الاكواد المنفصلة للفجوال بيزك للاكسل
الرجوع الى أعلى الصفحة 
صفحة 1 من اصل 1

صلاحيات هذا المنتدى:لاتستطيع الرد على المواضيع في هذا المنتدى
الاستاذ مجدى :: قسم مجموعة الاوفيس :: قسم الاكسل-
انتقل الى: