اكواد اعجبتنى

[قنديل الصياد]

مجموعة اكواد اعجبتنى

الكود الاول : تحية منى لاساتذتى بالمنتدى الرائع

Sub Elsiad()
'
' Elsiad ماكرو
' الماكرو مسجل ‎28/06/2013 بواسطة ‎Basim Magdy
  Range("j1").Select
    ActiveCell.FormulaR1C1 = "بسم الله الرحمن الرحيم"
    Range("j2").Select
    ActiveCell.FormulaR1C1 = "تحياتى لكل اساتذتى بمنتديات أوفيسنا"
     Range("j3").Select
      ActiveCell.FormulaR1C1 = "الاستاذ / عبد الله باقشير"
      Range("j4").Select
       ActiveCell.FormulaR1C1 = "الاستاذ / أحمد فضيلة"
       Range("j5").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / رجب جاويش"
        Range("j6").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / حماده عمر"
         Range("j7").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / هانى عدلى "
         Range("j8").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / جمال عبد السميع "
         Range("j9").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / احمد عبد الناصر "
         Range("j10").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / شوقى ربيع "
         Range("j11").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / جمال دغيدى "
          Range("j12").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / طارق محمود "
          Range("j13").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / ضاحى الغريب "
         Range("j14").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / عبد الله المجرب "
         Range("j15").Select
        ActiveCell.FormulaR1C1 = "الاستاذ / سعيد بيرم "
    Range("j16").Select
    
End Sub

الكود الثانى : دعاء وحصن جميل

Sub Hellomsg()
donkeyain:
Msg = "[ حصن لوقاية الانسان من شياطين الانس والجان ] "
Ans = MsgBox(Msg, vbYesNo)
If Ans = vbNo Then
MsgBox "هل تود الذهاب الى الدعاء"
GoTo donkeyain
Else
MsgBox "تحصنت بذى العزة والجبروت واعتصمت برب الملكوت وتوكلت على الحى الذى لا يموت & اصرف عنا الأذي انك على كل شئ قدير "
End If
End Sub

الكود الثالث : ترحيل بيانات

Sub sRange_Move()
    Sheets("ورقة2").Range("A9:c12").ClearContents
    Sheets("ورقة2").Range("a9:c12").ClearContents
    Sheets("ورقة2").Range("a9:c12").Value = Sheets("ورقة1").Range("A9:c12").Value
End Sub

^{الكود الرابع : جمع رقمين او اكثر}

Sub AddEmUp()
Sum = 50 + 170 + 30
MsgBox "النتيجة = " & Sum
End Sub

الكود الخامس : حفظ تلقائى للبيانات فى ملف اكسل دون الضغط على ايقونة الحفظ ويوضع الكود فى WorkBook

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.Save
 Application.Quit
End Sub

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

 

 

 

 

 

[هاني عدلي]

أخي الحبيب

قنديل الصياد

أكواد رائعة بارك الله فيك

=========

كل عام و انت بكل خير

====

خالص تحياتي لشخصك الكريم

 

     

 

[مجدى يونس]

الاخ قنديل الصياد

عمل منوع وافكار جميلة

كل عام وانت بخير

[اسلام سيد]

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

[قنديل الصياد]

أسعد الله قلوبكم وأمتعها بالخير دوماً

أسعدني كثيراً مروركم وتعطيركم هذه الصفحه

وردكم المفعم بالحب والعطاء

دمتم بخير وعافيه

 

 

[قنديل الصياد]

كود لساعة جميلة أعجبتنى

 

يوضع الكود التالى اولا فى صفحة WorkBook

Private Sub Workbook_Open()
    Call StartClock
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call StopClock
End Sub

ثم الأكواد التالية فى صقحة الموديل Moddule1

Option Explicit
Dim NextTick

Sub StartClock()
    UpdateClock
End Sub

Sub StopClock()
'   Cancels the OnTime event (stops the clock)
    On Error Resume Next
    Application.OnTime NextTick, "UpdateClock", , False
End Sub

Sub cbClockType_Click()
'   Hides or unhids the clock
    With ThisWorkbook.Sheets("Clock")
        If .DrawingObjects("cbClockType").Value = xlOn Then
            .ChartObjects("ClockChart").Visible = True
        Else
            .ChartObjects("ClockChart").Visible = False
        End If
    End With
End Sub

Sub UpdateClock()
'   Updates the clock that's visible
    Dim Clock As Chart
    Set Clock = ThisWorkbook.Sheets("Clock").ChartObjects("ClockChart").Chart
    
    If Clock.Parent.Visible Then
'       ANALOG CLOCK
        Const PI As Double = 3.14159265358979
        Dim CurrentSeries As Series
        Dim s As Series
        Dim x(1 To 2) As Variant
        Dim v(1 To 2) As Variant
    
'       Hour hand
        Set CurrentSeries = Clock.SeriesCollection("HourHand")
        x(1) = 0
        x(2) = 0.5 * Sin((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))
        v(1) = 0
        v(2) = 0.5 * Cos((Hour(Time) + (Minute(Time) / 60)) * (2 * PI / 12))
        CurrentSeries.XValues = x
        CurrentSeries.Values = v
        
'       Minute hand
        Set CurrentSeries = Clock.SeriesCollection("MinuteHand")
        x(1) = 0
        x(2) = 0.8 * Sin((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))
        v(1) = 0
        v(2) = 0.8 * Cos((Minute(Time) + (Second(Time) / 60)) * (2 * PI / 60))
        CurrentSeries.XValues = x
        CurrentSeries.Values = v
    
'       Second hand
        Set CurrentSeries = Clock.SeriesCollection("SecondHand")
        x(1) = 0
        x(2) = 0.85 * Sin(Second(Time) * (2 * PI / 60))
        v(1) = 0
        v(2) = 0.85 * Cos(Second(Time) * (2 * PI / 60))
        CurrentSeries.XValues = x
        CurrentSeries.Values = v
    Else
'       DIGITAL CLOCK
        ThisWorkbook.Sheets("Clock").Range("DigitalClock").Value = CDbl(Time)
    End If
    
'   Set up the next event one second from now
    NextTick = Now + TimeValue("00:00:01")
    Application.OnTime NextTick, "UpdateClock"
End Sub

مرفق ملف به التطبيق

 

 

 

 

 

تم تعديل يونيو 29, 2013 بواسطه قنديل الصياد

[حمادة عمر]

السلام عليكم

الاخ الكريم / قنديل الصياد

بارك الله فيك

اختيارات موفقة واكواد جميلة

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

[حمادة عمر]

رمضـــان كـــريـــم

[مصطفى كمال متولى]

السلام عليكم

الاخ الكريم / قنديل الصياد

بارك الله فيك

 

[قنديل الصياد]

كود لتحديد الاعمدة حسب ما تريد

Sub sRange_Select()
    Range("A1:A100,C1:C100,f1:f100").Select
End Sub

مرفق ملفق به التطبيق

 

 

[دغيدى]

أخى وبلدياتى / قنديل

خطواتكم جادة نحو مستقبل باهر

[قنديل الصياد]

كلمات جميلة من استاذى ومعلمى الكبير الاستاذ / جمال دغيدى ... أقف إجلالا وإحتراما وتوقيرا لكلماتك الراقية

ڳّلُ أَلَشِڳَرٌ لٌڳَـ وَلٌهٌذّأَ أٌلَمَرِوَرِ أَلٌجَمَيَلَ

 

[قنديل الصياد]

كود لعرض معلومات عن الملف الذى تعمل عليه

Sub ShowFolderSize(filespec)
Dim fs, F, S
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFile("E:\Bids.xls")
S = "File Name :" & UCase(F.Name) & vbLf & _
"Total Size: " & FormatNumber(F.Size) & " Kbytes" & vbLf & _
"Created :" & F.DateCreated & vbLf & _
"Modifide :" & F.DateLastModified & vbLf & _
"Last Accessed: " & F.DateLastAccessed
MsgBox S, 0, "File Size Info"
Open "Log.log" For Append As #2 'Open file
Print #2, S
Close #2 'Close
Exit Sub 'Exit
End Sub
'
Sub GetII()
'
ShowFolderSize (filespec)
'
End Sub

 

 

[قنديل الصياد]

كود لحذف البيانات من الخلايا الغير محمية وعدم حذف المعادلات فى الخلايا المحمية

Sub ragab()
On Error Resume Next
    ActiveSheet.Range("D2:N23").Value = vbNullString
End Sub

[قنديل الصياد]

كود إضافة القائمة المنسدلة إلى خلية في إكسل

Sub Add_Drop_Down_Menu_Cell()

With Range("C1").Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
Formula1:="=$B$1:$B$9"
.IgnoreBlank = True
.InCellDropdown = True
End With

End Sub  

مرفق ملف به التطبيق

 

 

[ابو عمرو محمد فارس]

شكرا شكرا  شكرا وهلا هلا هلا 

[arsalan]

اكواد اعجبتنى اكواد اعجبتنى

معذرة اين اجد الملف المرفق ؟؟

[ياسر خليل أبو البراء]

أخي الكريم أرسلان

ننتظر منك تغيير اسم الظهور للغة العربية

بعد إذن أخي وحبيبي قنديل الصياد

سأقوم بعمل ملفات مرفقة للأكواد الموجودة في الموضوع كل كود في ملف مرفق منفصل ليستفيد منه الجميع ..حيث لاحظت أن الملف المرفق الاستفادة منه أفضل من الأكواد بدون ملفات مرفقة

الملف الأول : الكود الأول في المشاركة الأولى (تم التعديل بما يتناسب مع عدم استخدام كلمة Select التي تبطيء من عمل الكود)

Sub Officena()
    Range("J1").FormulaR1C1 = "بسم الله الرحمن الرحيم"
    Range("J2").FormulaR1C1 = "تحياتى لكل أساتذتي بمنتديات أوفيسنا"
    Range("J3").FormulaR1C1 = "الأستاذ / عبد الله باقشير"
    Range("J4").FormulaR1C1 = "الأستاذ / أحمد فضيلة"
    Range("J5").FormulaR1C1 = "الأستاذ / رجب جاويش"
    Range("J6").FormulaR1C1 = "الأستاذ / حماده عمر"
    Range("J7").FormulaR1C1 = "الأستاذ / هاني عدلي"
    Range("J8").FormulaR1C1 = "الأستاذ / جمال عبد السميع "
    Range("J9").FormulaR1C1 = "الأستاذ / احمد عبد الناصر "
    Range("J10").FormulaR1C1 = "الأستاذ / شوقى ربيع"
    Range("J11").FormulaR1C1 = "الأستاذ / جمال دغيدي"
    Range("J12").FormulaR1C1 = "الأستاذ / طارق محمود"
    Range("J13").FormulaR1C1 = "الأستاذ / ضاحي الغريب"
    Range("J14").FormulaR1C1 = "الأستاذ / عبد الله المجرب"
    Range("J15").FormulaR1C1 = "الأستاذ / سعيد بيرم"
    Range("J16").FormulaR1C1 = "تلميذكم / ياسر خليل"
End Sub

تقبل تحياتي

Officena Staff YasserKhalil.rar

[ياسر خليل أبو البراء]

الكود الثاني في المشاركة الأولى

Sub MessageBoxTutorial()
    Dim Msg As String, Ans As Integer
donkeyain:
    Msg = "[ حصن لوقاية الإنسان من شياطين الإنس والجان ] "
    Ans = MsgBox(Msg, vbYesNo)
    
    If Ans = vbNo Then
        If MsgBox("هل تود الذهاب إلى الدعاء", vbYesNo) = vbYes Then
            GoTo donkeyain
        Else
            Exit Sub
        End If
    Else
        MsgBox "تحصنت بذي العزة والجبروت واعتصمت برب الملكوت" & vbNewLine & "وتوكلت على الحي الذى لا يموت. اصرف عنا الأذي إنك على كل شئ قدير"
    End If
End Sub

 

Message Box MsgBox Tutorial.rar

[حسام ميلكانا]

ما شاء الله ولا حول ولا قوة الا بالله

احبابى معلمين واساتذة هذ الصرح التعليمى كلية اوفيسنا

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

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

 

 

[أبوبسمله]

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

بالتوفيق اخى الحبيب

[ياسر خليل أبو البراء]

جزيتم خيراً إخواني الكرام على مروركم العطر بالموضوع

إليكم الكود الثالث في المشاركة الأولى

Sub sRange_Move()
    With Sheet2
        .Range("A9:C12").ClearContents
        .Range("A9:C12").Value = Sheet1.Range("A9:C12").Value
    End With
    
    MsgBox "تم الترحيل بنجاح", 64
End Sub

تقبلوا تحياتي

Transfer Data YasserKhalil.rar