MIDO189 قام بنشر أغسطس 21 مشاركة قام بنشر أغسطس 21 (معدل) اريد استخلاص بيانات معينه من ملف اكسيل اسم الطالب بجواره المواد اسم الماده + اسم الماده + اسم الماده RS_ST_196(8).xls تم تعديل أغسطس 21 بواسطه MIDO189 رابط هذا التعليق شارك More sharing options...
MIDO189 قام بنشر أغسطس 21 الكاتب مشاركة قام بنشر أغسطس 21 هل يوجد حل رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر أغسطس 21 أفضل إجابة مشاركة قام بنشر أغسطس 21 (معدل) وعليكم السلام ورحمة الله تعالى وبركاته اخي طريقة تصميمك للملف وكثرة الخلايا المدمجة وتنسيق عرض الصفوف ربما سوف يسبب لك عائق لظهور النتائج بشكل صحيح خاصة عند استخدام الاكواد على العموم لقد قمت بانشاء كودين لنفس المهمة واحد لاستخراج النتائج بالطريقة المطلوبة والاخر لاستخراجها على ورقة اخرى وتنسيقها يمكنك اختيار ما يناسبك 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 بواسطه محمد هشام. 1 رابط هذا التعليق شارك More sharing options...
MIDO189 قام بنشر أغسطس 22 الكاتب مشاركة قام بنشر أغسطس 22 (معدل) شكرا لك ممكن تقولى طريقة ادراج الاكواد تم تعديل أغسطس 22 بواسطه MIDO189 رابط هذا التعليق شارك More sharing options...
MIDO189 قام بنشر أغسطس 22 الكاتب مشاركة قام بنشر أغسطس 22 عذرا كيفية ادراج الكود رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 22 مشاركة قام بنشر أغسطس 22 أخي لقد تمت إظافة الأكواد مسبقا للملف المرفق رابط هذا التعليق شارك More sharing options...
MIDO189 قام بنشر أغسطس 23 الكاتب مشاركة قام بنشر أغسطس 23 نعم جزاك الله خيرا ولكن اريد اعرف الطريقه لكى اطبقه على شستات اخرى الخطوات رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 23 مشاركة قام بنشر أغسطس 23 (معدل) 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 بواسطه محمد هشام. 2 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان