بيانات الطلاب

[MIDO189]

اريد استخلاص بيانات معينه من ملف اكسيل

اسم الطالب    بجواره المواد   اسم الماده  + اسم الماده + اسم الماده

RS_ST_196(8).xls

تم تعديل أغسطس 21 بواسطه MIDO189

[MIDO189]

هل يوجد حل

 

[محمد هشام.]

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

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

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

 

Sub Collection_of_books()
    ' استخراج في ورقة RS_ST_196
    Dim WS As Worksheet, i As Long, lr As Long
    Dim lastRow As Long, n As String
    Dim studentName As String, ling As Long
    Dim bookName As String
    Dim bookNumber As Variant
    Dim startRow As Long
    
    Application.ScreenUpdating = False
    
    Set WS = ThisWorkbook.Sheets("RS_ST_196")
    lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row
    WS.Range("BC19:BD" & WS.Rows.Count).ClearContents
  
    ling = 19
    
    For i = 18 To lastRow
        If Not WS.Rows(i).Hidden Then
            studentName = WS.Cells(i, "AK").Value
            If InStr(studentName, "اسم الطالب: ") = 1 Then
                studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1))
                n = ""
                startRow = i + 2
                Do While WS.Cells(startRow, "AB").Value <> ""
                    bookName = WS.Cells(startRow, "AB").Value
                    bookNumber = WS.Cells(startRow, "AN").Value
                    If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _
                        Not IsEmpty(bookNumber) Then
                        If n = "" Then
                            n = bookName
                        Else
                            n = n & " + " & bookName
                        End If
                    End If
                    startRow = startRow + 1
                Loop
                WS.Cells(ling, "BD").Value = studentName
                WS.Cells(ling, "BC").Value = n
                ling = ling + 1
            End If
        End If
    Next i
    
    lr = WS.Cells(WS.Rows.Count, "BD").End(xlUp).row
    With WS.Range("BC19:BD" & lr)
        .MergeCells = False
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    
    Application.ScreenUpdating = True
    MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation
End Sub

 

Sub Collection_of_books_Sheet1()
    'Sheet1 نسخ على ورقة
    Dim WS As Worksheet, dest As Worksheet
    Dim lastRow As Long, i As Long
    Dim studentName As String, bookName As String, n As String
    Dim bookNumber As Variant, row As Range, lr As Long
    Dim startRow As Long, ling As Long, bCount As Integer
    Dim r As Long
    
    Application.ScreenUpdating = False
    
    Set WS = ThisWorkbook.Sheets("RS_ST_196")
    Set dest = ThisWorkbook.Sheets("Sheet1")
    
    lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row
    
    dest.Range("A2:C" & dest.Rows.Count).ClearContents
    ling = 2
    
    For i = 18 To lastRow
        If Not WS.Rows(i).Hidden Then
            studentName = WS.Cells(i, "AK").Value
            
            If InStr(studentName, "اسم الطالب: ") = 1 Then
                studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1))
                
                n = ""
                bCount = 0
                startRow = i + 2
                
                Do While WS.Cells(startRow, "AB").Value <> ""
                    bookName = WS.Cells(startRow, "AB").Value
                    bookNumber = WS.Cells(startRow, "AN").Value
                    If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And _
                        Not IsEmpty(bookNumber) Then
                        If n = "" Then
                            n = bookName
                        Else
                            n = n & " + " & bookName
                        End If
                        bCount = bCount + 1
                    End If
                    
                    startRow = startRow + 1
                Loop
                dest.Cells(ling, "A").Value = studentName ' اسماء الطلاب
                dest.Cells(ling, "B").Value = n           ' تجميع الكتب
                dest.Cells(ling, "C").Value = bCount      ' عدد الكتب لكل طالب
                ling = ling + 1
            End If
        End If
    Next i
    
    lr = dest.Cells(dest.Rows.Count, "A").End(xlUp).row
    
    With dest.Range("A2:C" & lr)
        .Borders.LineStyle = xlNone
        .MergeCells = False
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        
        r = dest.Cells(2, dest.Columns.Count).End(xlToLeft).Column
        Range(dest.Cells(2, 1), dest.Cells(lr, r)).Borders.Weight = xlThin
        
        For Each row In .Rows
            row.RowHeight = 35
        Next row
    End With
    
    Application.ScreenUpdating = True
    MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation
End Sub

يمكنك الغاء علامة (+) الموجودة بين الاسماء بتعديل هدا السطر 

n = n & " + " & bookName
الى 
n = n & "  " & bookName

 

RS_ST_196 V2.xls

تم تعديل أغسطس 21 بواسطه محمد هشام.

[MIDO189]

شكرا لك

ممكن تقولى طريقة ادراج الاكواد

 

تم تعديل أغسطس 22 بواسطه MIDO189

[MIDO189]

عذرا كيفية ادراج الكود

 

[محمد هشام.]

أخي لقد تمت إظافة الأكواد مسبقا للملف المرفق 

[MIDO189]

نعم جزاك الله خيرا ولكن اريد اعرف الطريقه لكى اطبقه على شستات اخرى

الخطوات

[محمد هشام.]

5 ساعات مضت, MIDO189 said:

عم جزاك الله خيرا ولكن اريد اعرف الطريقه لكى اطبقه على شستات اخرى

الخطوات

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

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

اما الاحتمال الثاني وهو الارجح على ما اعتقد  لكي تطبق الكود على ملفات اخرى لابد ان تفهمه  اولا لتتمكن من تعديله بما يناسبك 

سأقوم  بمحاولة اظافة بعض التعليقات المهمة للتوضيح 

Sub Collection_of_books_Sheet1()
    '****"RS_ST_196"' هذا الماكرو يقوم بتجميع أسماء الطلاب والكتب من ورقة
          ' ويقوم بنسخها إلى ورقة1 مع حساب عدد الكتب لكل طالب

    Dim WS As Worksheet, dest As Worksheet
    Dim lastRow As Long, i As Long
    Dim studentName As String, bookName As String, n As String
    Dim bookNumber As Variant, row As Range, lr As Long
    Dim startRow As Long, ling As Long, bCount As Integer
    Dim rngCell As Range
    
    Application.ScreenUpdating = False
    
    '***** تحديد أوراق العمل
    Set WS = ThisWorkbook.Sheets("RS_ST_196")
    Set dest = ThisWorkbook.Sheets("Sheet1")
    
    '********  "RS_ST_196" ,ورقة
    ' تحديد آخر صف في العمود AK
    lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row
    
    With dest.Range("A2:C" & dest.Cells(dest.Rows.Count, "A").End(xlUp).row)
        .ClearContents    ' مسح جميع البيانات في النطاق
        .ClearFormats     ' مسح جميع التنسيقات في النطاق
    End With

    
    ling = 2   ' بدء الكتابة من الصف 2 في ورقة  "Sheet1"
    
    ' حلقة لتمرير جميع الصفوف في ورقة المصدر من الصف 18 إلى آخر صف مستخدم
    For i = 18 To lastRow
        ' التحقق مما إذا كان الصف مخفيًا (إذا لم يكن مخفيًا، يتم معالجة الصف)
        If Not WS.Rows(i).Hidden Then
            ' الحصول على اسم الطالب من العمود "AK"
            studentName = WS.Cells(i, "AK").Value
            
            ' التحقق مما إذا كان اسم الطالب يبدأ بـ "اسم الطالب: "
            If InStr(studentName, "اسم الطالب: ") = 1 Then
                ' إزالة "اسم الطالب: " من بداية النص للحصول على الاسم الفعلي للطالب
                studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1))
                
                n = "" ' لتجميع أسماء الكتب
                bCount = 0 ' عداد للكتب
                startRow = i + 2 ' البدء من الصف الذي يليه للتحقق من الكتب
              
                ' حلقة لتمرير جميع الكتب المرتبطة بالطالب
                Do While WS.Cells(startRow, "AB").Value <> ""
                    bookName = WS.Cells(startRow, "AB").Value
                    bookNumber = WS.Cells(startRow, "AN").Value
                    '(عمود التسلسل م) التأكد من أن الكتاب ليس مجرد عنوان عمود وأن رقم الكتاب غير فارغ
                    If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And Not IsEmpty(bookNumber) Then
                        ' تجميع أسماء الكتب في متغير n
                        If n = "" Then
                            n = bookName
                        Else
                            n = n & " + " & bookName
                        End If
                        bCount = bCount + 1 ' زيادة عدد الكتب لكل طالب
                    End If
                    
                    startRow = startRow + 1 ' الانتقال إلى الصف التالي
                Loop
                 
                 '** نسخ النتائج
                
                ' كتابة اسم الطالب، أسماء الكتب المجتمعة، وعدد الكتب في ورقة الوجهة
                dest.Cells(ling, "A").Value = studentName ' اسم الطالب
                dest.Cells(ling, "B").Value = n           ' أسماء الكتب
                dest.Cells(ling, "C").Value = bCount      ' عدد الكتب
                ling = ling + 1 ' الانتقال إلى الصف التالي لكتابة بيانات الطالب التالي
            End If
        End If
    Next i
    
    '** تحديد آخر صف مستخدم في الاعمدة A:C   "Sheet1"
    lr = dest.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
    Set rngCell = dest.Range("A2:C" & lr)
    
    '** تنسيق الخلايا في النطاق المحدد
    With rngCell
        .Font.Bold = True ' تنسيق الخط
        .MergeCells = False ' التأكد من عدم دمج الخلايا
        .HorizontalAlignment = xlCenter ' ضبط المحاذاة الأفقية إلى الوسط
        .VerticalAlignment = xlCenter ' ضبط المحاذاة الرأسية إلى الوسط
        .WrapText = True ' تفعيل التفاف النص
        
     ' ضبط ارتفاع الصفوف إلى 35

        For Each row In .Rows
            row.RowHeight = 35
        Next row
    End With
  
    '** إضافة حدود للخلايا في النطاق
    For Each c In rngCell.Rows
        If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous
    Next
        
    Application.ScreenUpdating = True

    MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation
End Sub

 

 

 

 

 

تم تعديل أغسطس 23 بواسطه محمد هشام.