اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

قام بنشر

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

مرفق ملف

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

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

وفقك الله

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

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

  • Like 1
قام بنشر

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

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

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

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

وفقك الله

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

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

قام بنشر

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

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

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

وفقك الله

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

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

  • Like 1
قام بنشر

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

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

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

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

وفقك الله

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

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

  • Like 1
قام بنشر

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

Paste & Paste Special

عن نطاق محدد

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

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

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

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

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

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

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

  • Like 1
قام بنشر

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

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

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

  • Like 1
قام بنشر

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

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

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

  • Like 2
قام بنشر

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

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

  • Like 1
قام بنشر

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

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

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

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

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

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

وفقك الله

ابو الحارث

اكواد وتفعيل وتعطيل الحفظ العادي والحفظ باسم.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

قام بنشر

346594948.gif

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

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

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

قام بنشر

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

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

مرفق كود :

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

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

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

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

قام بنشر

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

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

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

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information