(موضوع مميز ) بعض الاكواد المنفصلة قد تهم البعض

[ياسر الحافظ]

استاذي العزيز " يحيــــــــــــــــــــــاوي "

مرفق ملف

كود للتنقل بين اوراق العمل ( هذا الكود له مشاركة مشابهة نوعا ما ) ولكن هذه المرة

بعض الاوراق ( ويمكن تحديدها من الكود ) لا تظهر فى القائمة من اعمال اخونا الاستاذ " عبد الله المجرب " ابو احمد

وفقك الله

ياسر الحافظ " ابو الحارث "

تنقل بين اوراق عمل مع اخفاء البعض من القائمة.rar

[ياسر الحافظ]

العزيز يحيـــــــــــــــــــــــاوي :

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

وكود لتحديد النطاق ($A$4:$H$100") ثم معاينة هذا النطاق مع تكرار الصف الاول الى الرابع في جميع الصفحات

من اعمال اخونا الاستاذ عبد الله المجرب " ابو احمد " بتصرف ياسر

وفقك الله

ياسر الحافظ " ابو الحارث "

الكود لعمل معاينة فقط مع تكرار صف.rar

[ياسر الحافظ]

العزيز يحيـــــــــــــــــــــــاوي :

هذا الكود - تجميد وتقسيم الشاشة -

من اعمال اخونا الاستاذ " عمر الحسيني " بتصرف يحياوي

وفقك الله

ياسر الحافظ " ابو الحارث "

يحياوي تجميد و تقسيم الشاشة2.rar

[ياسر الحافظ]

العزيز يحيـــــــــــــــــــــــاوي :

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

من اعمال اخونا الاستاذ " احمد حمور " بتصرف ياسر

ملاحظة : ( كود فتح اكسل على الفورم فقط ) اما اكواد الفورمز في الملف فهي من اعمال اعضاء واساتذة اخرين في هذا المنتدى

وفقك الله

ياسر الحافظ " ابو الحارث "

دخول الى الفورم مباشرة.rar

[محمد يحياوي]

الاخ الحبيب "ابو الحارث" بارك الله فيك ... شكرا جزيلا على الاكواد الجميلة و الامثلة الرائعة ... وفقك الله

[naderwatfa]

كود منع خاصية اللصق و اللصق الخاص

Paste & Paste Special

عن نطاق محدد

يفيد هذا الكود إذا كان عندك نطاق معين يحتوي على صلاحيات أو قوائم منسدلة مثلاً

و لا نريد أن يقوم المستخدم بالخطأ بلصق قيم أخرى فيها

الكود طبعاً يمنع هذه العملية

سواء من خلال الماوس

أو من خلال لوحة المفاتيح

الملف في المرفقات

منع اللصق و اللصق الخاص عن نطاق معين.rar

[محمد يحياوي]

الاخ العزيز "نادر" بارك الله فيك كود رائع حقا ... وفقك الله

[يوسف عطا]

كود جميل للأستاذ الكبير خبور خير

كود فتح الشيت بباس وورد

Private Sub Worksheet_Activate()

On Error Resume Next

Dim XX As String, S As String

Dim K As Integer, N As Integer

Me.Columns.Hidden = True

For K = 1 To 3

    XX = InputBox(Prompt:="فضلا ادخل كلمة المرور", Title:="المحاولة رقم:" & K)

    If XX = "" Then

        Sheets("Main").Select

        Exit Sub

    ElseIf XX <> "***" Then

        N = 3 - K

        If N = 0 Then S = "" Else S = "متبقي عدد " & N & " محاولة"

        MsgBox "كلمة المرور ليست صحيحة" & Chr(13) & Chr(13) & S, vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "عفواً"

    Else

        Exit For

    End If

Next K


If K = 4 Then

    Sheets("Main").Select

    Exit Sub

Else

    Me.Columns.Hidden = False

Columns("AD:IU").EntireColumn.Hidden = True

End If

On Error GoTo 0

End Sub

يوضع الباسوورد مكان الـ 3 نجوم ***

باسوورد للشيت.rar

[محمد يحياوي]

كود لتعطيل الماوس و لوحة المفاتيح مدة من الزمن

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub DesableMouKey()

BlockInput True

Sleep 10000

BlockInput False

End Sub

تعطيل الماوس لوحة المفاتيح.rar

[ياسر الحافظ]

العزيز " يحيـــــــــــــــــــــــــــاوي "

تسلم ايدك على الكود الجميل جدا مع الشكر والامتنان لهذ المتابعة المميزة والمشجعة لمشاركات الموضوع

مرفق كود :

عدم امكانية حفظ ملف اكسل الا بشرط - الشرح في المرفق -

من اعمال الاستاذ ابو عمر " كيمــــــــــــــــــــاس " بتصرف ياسر

وفقك الله

ابو الحارث

كود عدم حفظ الملف الا بشرط.rar

[محمد يحياوي]

الاخ الحبيب "ابو الحارث" بارك الله فيك ...كود جميل من اخينا الحبيب "كيماس"

و هذا كود اخر لتعطيل الحفظ باسم

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

If booAllowSave = False Then

    Cancel = True

    MsgBox "لا يمكنك الحفظ...", vbOKOnly, "منع الحفظ"

End If

End Sub


Private Sub Workbook_Open()

booAllowSave = False

End Sub

و هذا كود لتعطيل الاجراء للحفظ استثناء اذ انه لايمكن حفظ الكود داخل الملف و الدالة شغالة

'كتابة الكود في module

Global booAllowSave As Boolean


Sub yourSavefunction()

booAllowSave = True

    MsgBox "الحفظ جار...", vbokayonly, "تمكين الحفظ"

    Application.Dialogs(xlDialogSaveAs).Show

booAllowSave = False

End Sub

 

DisableSaveAs.rar

[محمد يحياوي]

كود اظهار رسائل عشوائية مختلفة كل فترة من الزمن

Sub yah_msgs()




    Const Title As String = "مرحبا : منتدى اوفيسنا"

    Const Delay As Byte = 3


    Dim wsh As Object

    Set wsh = CreateObject("WScript.Shell")

    Dim strQuotes(2) As String

    Dim lngIndex As Long

    strQuotes(0) = "السلام عليكم و رحمة الله" & vbLf & vbLf & "اليوم هو " & Date

    strQuotes(1) = "كل عام وانتم بخير" & vbLf & vbLf & "اليوم هو " & Date

    strQuotes(2) = "تقبل الله منا ومنكم" & vbLf & vbLf & "اليوم هو " & Date


    lngIndex = Int((2 - 0 + 1) * Rnd + 0)


    wsh.Popup strQuotes(lngIndex), Delay, Title, wButtons

    Set wsh = Nothing

    Application.OnTime Now + TimeValue("00:00:5"), "yah_msgs"

End Sub

كما يمكن وضع الكود في حدث فتح المصنف

Private Sub Workbook_Open()

yah_msgs.rar

[الحسامي]

السلام عليكم

بالنسبة لاكواد الحفظ

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

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

   If SaveAsUI = True Then Cancel = True

End Sub

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

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Cancel = True

    If SaveAsUI = True Then Cancel = False

End Sub

[محمد يحياوي]

الاخ الحبيب "الحسامي" بارك الله فيك اكواد جميلة و رائعة ... وفقك الله

هذا كود ربط ماكرو بزر اختيار (CheckBox)

macro_CheckBoxs.rar

[ياسر الحافظ]

الاخ الحبيب "الحسامي" بارك الله فيك اكواد جميلة و رائعة ... وفقك الله

هذا كود ربط ماكرو بزر اختيار (CheckBox)

العزيز يحيـــــــــــــــــياوي :

الحقيقة كود جميل جدا ... تسلم ايدك

وعذرا من الاستاذ الحسامي ( ارفق اكواد الحفظ من مشاركة الاستاذ الحسامي - تفعيل وتعطيل الحفظ العادي والحفظ باسم وبالعكس - )

ضمن ملفين اكسل

وفقك الله

ابو الحارث

اكواد وتفعيل وتعطيل الحفظ العادي والحفظ باسم.rar

[محمد يحياوي]

ربط ماكرو ب optionbottons

macro_optionbotton.rar

[محمد يحياوي]

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

مثال1: ماكرو فتح فورم

Sub showform()

UserForm1.Show

End Sub

و في حدث فتح المصنف

Private Sub Workbook_Open()

Application.OnTime Now + TimeValue("00:00:05"), "showform"

End Sub

مثال2: ماكرو اخفاء الفورم

Sub Hideform()

UserForm1.Hide

End Sub

وفي حدث UserForm_Initialize

Private Sub UserForm_Initialize()

Application.OnTime Now + TimeValue("00:00:05"), "Hideform"

End Sub

تنفيذ ماكرو بعد مدة.rar

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

كود لحذف قيمة في خلية معينة في جميع اوراق العمل

من اعداد الاستاذ عماد الحسامي

Dim x As Worksheet

Application.ScreenUpdating = False

For Each x In Application.Worksheets

x.Range(Sheet4.Range("e16")) = Empty

Next x

رابط الموضوع

http://www.officena.net/ib/index.php?showtopic=38024

[محمد يحياوي]

كود تمرير نص كل مدة في يوزر فورم

تمرير نص كل مدة في يوزر فورم.rar

[محمد يحياوي]

كود بحث و تصفية في قائمة منسدلة بأي حرف او كلمة من نص

AoutoFilterSearchWord.rar

[جمال الفار]

اعمال رائعة

اشعر امامها اننى امام كنز من الكنوز التى لا تعوض كنوز فى هيئة اشخاص وكنوز فى هيئة اكواد

وللمشاركة هذا كود قد استفدت منه فى المنتدى وهو لاحد الاخوة جزاه الله خيرا

ولا اعرف اذا كان قد وضع هنا ام لا

وفقكم الله وجزاكم الله خيرا

تحديد الطباعة يدويا او بالماوس _الفار.rar

[جمال الفار]

السلام عليكم

جزاك الله خيرا على كلمتك الرقيقة اخى ابو الاء

شكرا اخى يحياوى

وهذا هو رابط الملف الثانى وفقكم الله

http://www.officena.net/ib/index.php?showtopic=30517

[ياسر الحافظ]

العزيز يحيـــــــــــــــــــــــــاوي :

تسلم ايدك ... وشكر جزيل لكل الاخوة المشاركين

مرفق كود :

مسح ( او كتابة كلمة محددة ) للخلية المقابلة لتاريخ محدد

مسح ( او كتابة كلمة محددة ) للاخلايا المقابلة لنطاق تاريخ ( من -- الى )

من اعمال الاستاذ الحســــــــــــــــــــــــــــــامي ( بتصرف ياسر )

- الحسامي - مسح محتوى خليه بتاريخ.rar

[محمد يحياوي]

كود نعطيل الاكمال التلقائي للنص في الخلية

Application.EnableAutoComplete = False

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

كود بحث وإضافة من اعداد الاستاذ الخالدي

رابط المشاركة الاصلية

x1 = InputBox(" ادخل نص البحث", "بحث وإضافة")

If IsNull(x1) Or x1 = "" Then Exit Sub

x2 = InputBox("البحث عن : " & x1 & Chr(13) & Chr(13) & "  ادخل نص الإضافة", "بحث وإضافة")

If IsNull(x2) Or x2 = "" Then Exit Sub

On Error GoTo Error:

r1 = "$A$1"

r2 = "$A$1"

1:

r3 = Cells.Find(What:=x1, After:=Range(r2), LookIn:=xlValues, LookAt:=xlPart).Address

s = s + 1

r2 = r3

If s = 1 Then r1 = r3 Else If r1 = r3 Then GoTo 2

x3 = Range(r2).Value

x4 = x3 & " " & x2

Range(r2).Replace What:=x3, Replacement:=x4, LookAt:=xlPart

GoTo 1

2:

MsgBox ("عدد النتائج:" & s - 1)

Exit Sub

Error:

MsgBox ("لايوجد نتائج")

بحث وإضافة.rar