12 كود VBA اكسيل جاهز للتطبيق

يبحث الكثير من المهتمين بالاكسيل excel وتطبيقاته المختلف عن أكواد VBA جاهزه للتطبيق مباشرة، إليك بعض الأكواد VBA جاهزة للتطبيق مع شرح النتائج المتوقعة لكل كود:

1. كود لنسخ البيانات من ورقة إلى أخرى:

   Sub CopyData()
       Sheets("Sheet1").Range("A1:B10").Copy
       Sheets("Sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
       Application.CutCopyMode = False
   End Sub

النتيجة المتوقعة: هذا الكود سيقوم بنسخ البيانات من النطاق A1:B10 في الورقة “Sheet1” ولصقها كقيم في الخلية A1 في الورقة “Sheet2”.

2. كود لتغيير لون الخلفية للخلايا التي تحتوي على قيم معينة:

   Sub HighlightCells()
       Dim cell As Range
       For Each cell In Range("A1:A10")
           If cell.Value > 100 Then
               cell.Interior.Color = RGB(255, 0, 0) ' اللون الأحمر
           End If
       Next cell
   End Sub

النتيجة المتوقعة: هذا الكود سيغير لون الخلفية للخلايا في النطاق A1:A10 إلى الأحمر إذا كانت قيمتها أكبر من 100.

3. كود لإظهار رسالة ترحيبية:

   Sub WelcomeMessage()
       MsgBox "أهلاً بك في Excel VBA!", vbInformation, "ترحيب"
   End Sub

النتيجة المتوقعة: هذا الكود سيعرض رسالة منبثقة تحتوي على النص “أهلاً بك في Excel VBA!” بعنوان “ترحيب”.

4. كود لحساب مجموع القيم في عمود محدد:

   Sub SumColumn()
       Dim total As Double
       total = Application.WorksheetFunction.Sum(Range("A1:A10"))
       MsgBox "مجموع القيم في العمود A هو: " & total
   End Sub

النتيجة المتوقعة: هذا الكود سيحسب مجموع القيم في النطاق A1:A10 وسيعرضه في رسالة منبثقة.

5. كود لإدراج تاريخ اليوم في خلية محددة:

   Sub InsertCurrentDate()
       Range("B1").Value = Date
   End Sub

النتيجة المتوقعة: هذا الكود سيقوم بإدراج تاريخ اليوم في الخلية B1

بعض الأكواد الإضافية التي تغطي مجموعة متنوعة من المهام في Excel VBA:

6. كود للبحث عن قيمة واستبدالها:

Sub FindAndReplace()
    Dim ws As Worksheet
    Dim rng As Range

    Set ws = Sheets("Sheet1")
    Set rng = ws.Cells

    rng.Replace What:="OldValue", Replacement:="NewValue", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End Sub

النتيجة المتوقعة: هذا الكود سيبحث عن جميع الخلايا التي تحتوي على “OldValue” في الورقة “Sheet1” ويستبدلها بـ “NewValue”.

7. كود لإضافة صف جديد:

Sub InsertNewRow()
    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")
    ws.Rows(5).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

النتيجة المتوقعة: هذا الكود سيضيف صفًا جديدًا قبل الصف الخامس في الورقة “Sheet1”.

8. كود لحذف صفوف فارغة:

Sub DeleteEmptyRows()
    Dim ws As Worksheet
    Dim rng As Range
    Dim i As Long

    Set ws = Sheets("Sheet1")
    Set rng = ws.UsedRange

    For i = rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(rng.Rows(i)) = 0 Then
            rng.Rows(i).EntireRow.Delete
        End If
    Next i
End Sub

النتيجة المتوقعة: هذا الكود سيقوم بحذف جميع الصفوف الفارغة في الورقة “Sheet1”.

9. كود لإنشاء تقرير بسيط:

Sub CreateSimpleReport()
    Dim ws As Worksheet
    Set ws = Sheets.Add
    ws.Name = "Report"

    ws.Range("A1").Value = "تقرير بسيط"
    ws.Range("A2").Value = "تاريخ التقرير:"
    ws.Range("B2").Value = Date

    ws.Range("A4").Value = "البند"
    ws.Range("B4").Value = "القيمة"

    ws.Range("A5").Value = "إجمالي المبيعات"
    ws.Range("B5").Value = 12345 ' قيمة افتراضية

    ws.Range("A6").Value = "إجمالي المصاريف"
    ws.Range("B6").Value = 6789 ' قيمة افتراضية
End Sub

النتيجة المتوقعة: هذا الكود سينشئ ورقة جديدة باسم “Report” ويملؤها ببعض البيانات الأساسية لتقرير بسيط.

10. كود لإرسال بريد إلكتروني باستخدام Outlook:

Sub SendEmail()
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "example@example.com"
        .CC = ""
        .BCC = ""
        .Subject = "اختبار إرسال بريد إلكتروني"
        .Body = "هذه رسالة اختبارية."
        .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

النتيجة المتوقعة: هذا الكود سيقوم بإرسال بريد إلكتروني باستخدام Outlook مع الموضوع والنص المحددين.

11. كود لتكرار عملية بناءً على شرط:

Sub LoopWithCondition()
    Dim i As Integer

    For i = 1 To 10
        If Cells(i, 1).Value > 50 Then
            Cells(i, 2).Value = "قيمة عالية"
        Else
            Cells(i, 2).Value = "قيمة منخفضة"
        End If
    Next i
End Sub

النتيجة المتوقعة: هذا الكود سيتحقق من القيم في العمود A من الصف 1 إلى 10، وسيضع في العمود B “قيمة عالية” إذا كانت القيمة أكبر من 50 و”قيمة منخفضة” إذا كانت أقل أو تساوي 50.

12. كود لتطبيق تنسيق مخصص:

Sub CustomFormatting()
    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")

    With ws.Range("A1:A10")
        .Font.Bold = True
        .Font.Color = RGB(255, 0, 0) ' اللون الأحمر
        .Interior.Color = RGB(255, 255, 0) ' اللون الأصفر
    End With
End Sub

النتيجة المتوقعة: هذا الكود سيجعل النص في النطاق A1:A10 بخط عريض ولونه أحمر، بينما ستكون خلفية الخلايا صفراء.

إذا كنت بحاجة إلى المزيد من الأكواد أو مهام محددة، يمكنك ان تتركها فى التعليقات و هنكتبلك الكود فى اسرع وقت ان شاء الله.