abouelhassan

جرب

Sub نقل_البيانات()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim nextRow As Long
    
    ' افتح ورقة العمل الحالية
    Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك
    
    ' قم بإنشاء ورقة النتيجة إذا لم تكن موجودة بالفعل
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("النتيجة هنا")
    On Error GoTo 0
    
    If wsResult Is Nothing Then
        Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count))
        wsResult.Name = "النتيجة هنا"
    End If
    
    ' حساب آخر صف غير فارغ في عمود F
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ' نقل البيانات إلى ورقة النتيجة باستثناء الأسطر الفارغة في عمود F
    nextRow = 1 ' الصف التالي المتاح في ورقة النتيجة
    For i = 1 To lastRow
        If ws.Cells(i, "F").Value <> "" Then
            ws.Rows(i).Copy wsResult.Rows(nextRow)
            nextRow = nextRow + 1
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح!"
End Sub

جرب

Sub InsertPageBreaks()
    Dim ws As Worksheet
    Dim rowsPerPage As Integer
    Dim lastRow As Long
    Dim i As Long

    ' تعيين عدد الصفوف في كل صفحة
    rowsPerPage = 24

    ' تحديد الورقة التي ترغب في تطبيق الفواصل عليها
    Set ws = ThisWorkbook.Sheets("Sheet1") ' تغيير "Sheet1" إلى اسم الورقة الخاصة بك

    ' حذف الفواصل الحالية إن وجدت
    ws.ResetAllPageBreaks

    ' الحصول على آخر صف غير فارغ في الورقة
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' إدراج فواصل الصفحات بعد كل rowsPerPage صف
    For i = rowsPerPage To lastRow Step rowsPerPage
        ws.Rows(i).PageBreak = xlPageBreakManual
    Next i
End Sub

قم بتغيير "Sheet1" في السطر Set ws = ThisWorkbook.Sheets("Sheet1") إلى اسم الورقة التي ترغب في تطبيق الفواصل عليها.

قم بتعديل قيمة rowsPerPage إلى العدد المطلوب من الصفوف في كل صفحة.

جرب

Sub إنشاء_صف_جديد()
    ' تحديد الصف الحالي
    Dim صف_حالي As Integer
    صف_حالي = ActiveCell.Row
    
    ' نسخ الصف الحالي
    Rows(صف_حالي & ":" & صف_حالي).Copy
    
    ' لصق في الصف التالي
    Rows(صف_حالي + 1 & ":" & صف_حالي + 1).Insert Shift:=xlDown
    
    ' ضبط الترقيم التلقائي للصفوف
    Rows(صف_حالي + 1).Cells(1, 1).Formula = Rows(صف_حالي).Cells(1, 1).Formula + 1
    
    ' إلغاء تحديد الصفوف
    Application.CutCopyMode = False
End Sub

للتنفيذ بواسطة زر انتر استخدم الاتى

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' تحقق من أن الزر هو زر Enter
    If Target.Address = ActiveCell.Address Then
        ' الكود الذي يقوم بإنشاء صف جديد
        Rows(Target.Row & ":" & Target.Row).Copy
        Rows(Target.Row + 1 & ":" & Target.Row + 1).Insert Shift:=xlDown
        Rows(Target.Row + 1).Cells(1, 1).Formula = Rows(Target.Row).Cells(1, 1).Formula + 1
        Application.CutCopyMode = False
        
        ' إلغاء تنفيذ افتتاح زر Enter
        Cancel = True
    End If
End Sub

جرب

Sub نقل_البيانات()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' افتح ورقة العمل الحالية
    Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك
    
    ' قم بإنشاء ورقة النتيجة إذا لم تكن موجودة بالفعل
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("النتيجة هنا")
    On Error GoTo 0
    
    If wsResult Is Nothing Then
        Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count))
        wsResult.Name = "النتيجة هنا"
    End If
    
    ' حساب آخر صف غير فارغ في عمود F
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ' نقل البيانات إلى ورقة النتيجة باستثناء الأسطر الفارغة في عمود F
    For i = 1 To lastRow
        If ws.Cells(i, "F").Value <> "" Then
            ws.Rows(i).Copy wsResult.Rows(wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1)
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح!"
End Sub

2 ساعات مضت, بلانك said:

شكرا جزيلا وبارك الله فيك ...... ولكن ان امكن وضع كل اسم في خلية واحدة وصف واحد اسفل بعضهم لنفس العمود C انظر الصورة للمتوقعة

 

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

Private Sub Workbook_Open()
    ' جعل الصفحة من اليمين والتنسيق في المنتصف
    With ActiveWindow
        .WindowState = xlMaximized
        .DisplayRightToLeft = True
    End With
    
    ' تنسيق الأرقام بخط عريض بحجم 14
    Cells.NumberFormat = "0"
    Cells.Font.Size = 14
    
    ' تنسيق العمود A برقم مخصص 000000
    Columns("A").NumberFormat = "000000"
    
    ' تنسيق العمود B بتكست
    Columns("B").NumberFormat = "@"
    
    ' تقسيم الأسماء في العمود C
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        Dim fullNameA As String
        Dim fullNameB As String
        Dim combinedNames As String
        
        ' قراءة الأسماء من العمود A و B
        fullNameA = Cells(i, "A").Value
        fullNameB = Cells(i, "B").Value
        
        ' المقارنة والتحقق من الأسماء المتطابقة
        If InStr(fullNameB, fullNameA) > 0 Or InStr(fullNameA, fullNameB) > 0 Then
            combinedNames = fullNameA
        Else
            combinedNames = fullNameA & vbCrLf & fullNameB
        End If
        
        ' وضع الأسماء في العمود C
        Cells(i, "C").Value = combinedNames
    Next i
End Sub

في الكود أدناه، يتم مقارنة الأسماء في العمود A والعمود B، وإذا كانت الأسماء متطابقة، يُكتب الاسم في العمود C، وإذا كانت مختلفة، يتم فصلها تمامًا في العمود 😄

Private Sub Workbook_Open()
    ' جعل الصفحة من اليمين والتنسيق في المنتصف
    With ActiveWindow
        .WindowState = xlMaximized
        .DisplayRightToLeft = True
    End With
    
    ' تنسيق الأرقام بخط عريض بحجم 14
    Cells.NumberFormat = "0"
    Cells.Font.Size = 14
    
    ' تنسيق العمود A برقم مخصص 000000
    Columns("A").NumberFormat = "000000"
    
    ' تنسيق العمود B بتكست
    Columns("B").NumberFormat = "@"
    
    ' تقسيم الأسماء في العمود C
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRow
        Dim fullNameA As String
        Dim fullNameB As String
        
        ' قراءة الأسماء من العمود A و B
        fullNameA = Cells(i, "A").Value
        fullNameB = Cells(i, "B").Value
        
        ' المقارنة والفصل في العمود C
        If InStr(fullNameB, fullNameA) > 0 Or InStr(fullNameA, fullNameB) > 0 Then
            Cells(i, "C").Value = fullNameA
        Else
            Cells(i, "C").Value = fullNameA & " / " & fullNameB
        End If
    Next i
End Sub

لإلغاء إدخال البيانات في عمود معين في Excel، يمكنك استخدام حماية الورقة وتحديد الخلايا التي تريد حمايتها. يمكنك اتباع الخطوات التالية:

1. افتح ورقة العمل في Excel.

2. حدد العمود الذي تريد حمايته (على سبيل المثال، عمود D).

3. انقر بزر الماوس الأيمن على العمود المحدد واختر "تنسيق الخلايا" (Format Cells).

4. انتقل إلى علامة التبويب "الحماية" (Protection).

5. حدد خيار "قفل الخلية" (Locked).

ثم، اذهب إلى:

6. انقر بزر الماوس الأيمن على علامة التبويب "الورقة" (Sheet) في أسفل النافذة.

7. اختر "حماية الورقة" (Protect Sheet).

8. ادخل كلمة مرور إذا كنت ترغب في ذلك واختر الخيارات التي تناسب احتياجاتك.

بعد الانتهاء من هذه الخطوات، ستكون البيانات في العمود D محمية ولن يمكن تعديلها إلا إذا تم إلغاء حماية الورقة باستخدام كلمة المرور التي قمت بتحديدها.

وعليكم السلام.

للأسف، عندما يتم تحميل ملف إكسل على Google Drive، قد يتم فقدان بعض خصائص الحماية التي قمت بها في الكمبيوتر. هذا يعود إلى طريقة عمل Google Drive وتفاعله مع ملفات Office.

للتحكم بصلاحيات الوصول على Google Drive، يفضل استخدام خيارات الحماية المتوفرة على المستوى الخاص بـ Google Drive نفسه، بدلاً من الاعتماد فقط على حماية الورقة أو الخلية داخل الملف.

يمكنك قفل ملفك على Google Drive من خلال اختيار الخيارات المناسبة في واجهة Google Drive. لتقديم الوصول بصورة قراءة فقط، اختار "مشاركة" ثم "حدد الذين يمكنهم الوصول" وحدد "قارئ" بدلاً من "محرر".

جرب

Sub كتابة_الصدق_كل_20_صف()
    Dim صف As Integer
    Dim الصدق As String
    الصدق = "الصدق"
    
    ' تحديد صفوف للكتابة فيها
    For صف = 1 To ActiveSheet.Rows.Count Step 20
        ' كتابة الكلمة في الخلية A في الصف الحالي
        Cells(صف, 1).Value = الصدق
    Next صف
End Sub

في 1‏/2‏/2024 at 12:37, John Refaat said:

معادلة sumifs بشرط التاريخ

جرب

=SUMIFS(B:B, A:A, ">="&تاريخ_البداية, A:A, "<="&تاريخ_النهاية)

شكر وتقدير واحترام من اخيك 

تسلم ايدك اخى استاذ محمد هشام.

شكر وتقدير واحترام من اخيك

خالص الشكر استاذ محمد حسن المحمد

اعزك الله 

احتاج كود لتنفيذ نظرا لكبر حجم الداتا 

بارك الله فيك واعزك اللهم امين يارب العالمين

السلام عليكم ورحمة الله اخوانى الافاضل

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

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

لدينا شيتان الاول به ثلاث اعمدة الاسم والرقم القومى والمبلغ

والشيت الثانى اسمه تجميع بدون تكرار

احتاج كود للبحث فى عمود الرقم القومى اذا كان مكرر يجمع المبلغ 

بارك الله فيكم اخوانى الافاضل

كود تجميع .xlsx

شكر وتقدير واحترام من اخيك 

مشكور اخي الكريم

احتاج حل بدون تقسيم القاعدة

بارك الله فيك اخي 

السلام عليكم ورحمه الله اخوانى الافاضل

اتقدم لكم بخالص الشكر والتقدير

لدى مشكلة أن شاء الله اجد لها حل لديكم

لدى قاعدة بيانات تعمل بفضل الله وفضلكم تمام 

أضعها على جوجل درايف لكى اعمل عليها من اى مكان

المشكلة هى أننى عندما اعمل لايتم حفظ البيانات الا بلغق القاعدة 

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

احتاج لشى يجعل البيانات تحفظ والبرنامج لم يغلق حتى إذا انقطع النت وأغلقت البرنامج اجد ما تم إدخاله موجود ولا يضيع مجهودى.

ملحوظة لدى كود حفظ نسخة احتياطية بس هذا ليس ما احتاجه 

احتاج حفظ البيانات المدخلة اول باول حتى لو النت قطع يحفظك البيانات حتى آخر لحظة كان بها نت أو شئ من هذا القبيل

شاكر لكم كرمكم

شكر وتقدير واحترام من اخيك 

شكر وتقدير واحترام 

شكر وتقدير واحترام من اخيك 

شكر وتقدير واحترام 

شكر وتقدير واحترام 

متابع

شكر وتقدير واحترام من اخيك

الف الف مبروك