| بعض الاكواد المنفصلة للفجوال بيزك للاكسل | |
|
|
كاتب الموضوع | رسالة |
---|
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الجمعة فبراير 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الجمعة فبراير 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
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الجمعة فبراير 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
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الجمعة فبراير 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأربعاء فبراير 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأربعاء فبراير 15, 2017 9:18 pm | |
| التحكم فى تنسيق القيم المدخله فى التكست بوكس بوضع علامه عشريه Private Sub TextBox1_AfterUpdate() TextBox1.Text = Format(TextBox1.Text, "0.0") End Sub
هنا نوع التنسيق "0.0" يكون رقم واحد بعد العلامه العشريه مثال لو حضرتك ادخلت 20 فقط ستجد التكست بوكس اصبح 20.0
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأربعاء فبراير 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
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأحد فبراير 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأحد فبراير 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
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأربعاء فبراير 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
فوازنور6
عدد المساهمات : 1 تاريخ التسجيل : 17/03/2017
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل السبت مارس 18, 2017 7:00 pm | |
| عمل في غاية الأهمية جزاك الله كل خير أستاذ | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الأحد مارس 19, 2017 4:42 pm | |
| _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
محمود عبيد
عدد المساهمات : 8 تاريخ التسجيل : 02/04/2017
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل السبت أبريل 29, 2017 3:33 am | |
| | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الثلاثاء أكتوبر 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الثلاثاء أكتوبر 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
_________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
مجدى يونس Admin
عدد المساهمات : 3781 تاريخ التسجيل : 22/02/2013 العمر : 69
| موضوع: رد: بعض الاكواد المنفصلة للفجوال بيزك للاكسل الثلاثاء أكتوبر 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 _________________ لا تعطيني سمكة ... و لكن علمني كيف أصطاد السمك | |
|
| |
| بعض الاكواد المنفصلة للفجوال بيزك للاكسل | |
|