تعديل كود

[علي المصري]

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

الكود التالي يقوم بجلب الاسماء من  StudentsNames إلى  Analysis 

يبحث فقط عن اسماء الشعب المكتوبة بهذه الطريقة  مثلا
  12A 
 أو 
 12-1

اريد التعديل بحيث يبحث ايضا عن الشعبة اذا تم كتابتها بهذه الطريقة

12/1

حاولت التعديل ولم استطع ( هذا الكود لاحد الاعضاء منذ فترة ولكني لا اتذكر الاسم ) 

 

Set rng1 = Worksheets("StudNames"): Set rng2 = Worksheets("Analysis")

S = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "-" & Right(rng2.[AB1], 1): t = rng2.[AB1]

X = Application.CountIf(rng1.Range("B:B"), S) + Application.CountIf(rng1.Range("B:B"), t)

Y = IIf(Range("LangCod") = 2, 5, 4)


rng2.Range("B8:C42") = Empty
For i = 1 To X
  rng2.Cells(7 + i, "B").Value = i
  For Each cel In rng1.Range("B2:B5000")
    If (cel = S Or cel = t) And cel.Offset(0, -1) = i Then _
        rng2.Cells(7 + i, "C").Value = rng1.Cells(cel.Row, Y).Value
  Next
Next

 

1111.xlsb

تم تعديل ديسمبر 13, 2021 بواسطه علي المصري
اضافة مرفق

[علي المصري]

المرفق بعد الغاء الحماية

1111.xlsb

[علي المصري]

توصلت إلى حل عن طريق اضافة عمود في صفحة الاسماء 

كما هو موضح بالمرفق

واستخدمت المعادلة التالية 

=IFERROR(IF(LangCod=2,VLOOKUP($AB$1&"|"&A8,StudentsNames,5,0),VLOOKUP($AB$1&"|"&A8,StudentsNames,4,0)),"")

ولكن ما زلت اطمع في حل عن طريق تعديل الكود

1111.xlsb

[حسونة حسين]

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

اخى الكريم الكود المرفق في ملفك يعمل وليس به اي مشكله

 

[علي المصري]

معذرة
المطلوب هو 

عند كتابة  قيمة الخلية AB1 تساوي أي من الاشكال التالية

12A

12-1

12/1

يقوم بالبحث عنها في اسماء الطلاب بحيث اذل وجده في اسماء الطلاب 12A يعطيني البيانات أو اذا وجده اي حالة من الحالتين الاخرين تعطي النتيجة ايضا

ولا اريد ان يعتمد على البيانات الموجود في العمود A في اسماء الطلاب

تم تعديل ديسمبر 14, 2021 بواسطه علي المصري

[محي الدين ابو البشر]

Sub MyStuNames()
On Error Resume Next
Application.ScreenUpdating = False
Set rng1 = Worksheets("StudNames"): Set rng2 = Worksheets("Analysis")

S = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "-" & Right(rng2.[AB1], 1): t = rng2.[AB1]
S2 = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "/" & Right(rng2.[AB1], 1): t2 = rng2.[AB1]

X = Application.CountIf(rng1.Range("B:B"), S) + Application.CountIf(rng1.Range("B:B"), t) + Application.CountIf(rng1.Range("B:B"), S2)
Y = IIf(Range("LangCod") = 2, 5, 4)


rng2.Range("B8:C42") = Empty
For i = 1 To X
  rng2.Cells(7 + i, "B").Value = i
  For Each cel In rng1.Range("B2:B5000")
    If (cel = S Or cel = t Or cel = t1) And cel.Offset(0, -1) = i Then _
        rng2.Cells(7 + i, "C").Value = rng1.Cells(cel.Row, Y).Value
  Next
Next




Application.ScreenUpdating = True
End Sub

هكذا؟

[حسونة حسين]

اقتباس

 

المطلوب هو 

عند كتابة  قيمة الخلية AB1 تساوي أي من الاشكال التالية

12A

12-1

12/1

يقوم بالبحث عنها في اسماء الطلاب بحيث اذل وجده في

اسماء الطلاب 12A يعطيني البيانات أو اذا وجده اي حالة من الحالتين

الاخرين تعطي النتيجة ايضا

وهذا ما بحدث عند تشغيل كودك

 

اقتباس

ولا اريد ان يعتمد على البيانات الموجود في العمود A في اسماء الطلاب

مش فاهم دى بصراحه

[علي المصري]

1 ساعه مضت, محي الدين ابو البشر said:

Sub MyStuNames()
On Error Resume Next
Application.ScreenUpdating = False
Set rng1 = Worksheets("StudNames"): Set rng2 = Worksheets("Analysis")

S = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "-" & Right(rng2.[AB1], 1): t = rng2.[AB1]
S2 = Mid(rng2.[AB1], 1, Len(rng2.[AB1]) - 1) & "/" & Right(rng2.[AB1], 1): t2 = rng2.[AB1]

X = Application.CountIf(rng1.Range("B:B"), S) + Application.CountIf(rng1.Range("B:B"), t) + Application.CountIf(rng1.Range("B:B"), S2)
Y = IIf(Range("LangCod") = 2, 5, 4)


rng2.Range("B8:C42") = Empty
For i = 1 To X
  rng2.Cells(7 + i, "B").Value = i
  For Each cel In rng1.Range("B2:B5000")
    If (cel = S Or cel = t Or cel = t1) And cel.Offset(0, -1) = i Then _
        rng2.Cells(7 + i, "C").Value = rng1.Cells(cel.Row, Y).Value
  Next
Next




Application.ScreenUpdating = True
End Sub

هكذا؟

شكرا جزيلا استاذ محي الدين 

اذا تم حذف الترقيم الموجود في العمود A في صفحة اسماء الطلاب 

وتشغيل الكود لا يعطي اي اسماء 

وكذلك اذا تم ترقيم الاسماء كلها بتسلسل واحد مثلا من 1 الى 100 

 

6 دقائق مضت, hassona229 said:

مش فاهم دى بصراحه

اذا تم حذف الترقيم الموجود في العمود A في صفحة اسماء الطلاب 

وتشغيل الكود لا يعطي اي اسماء 

وكذلك اذا تم ترقيم الاسماء كلها بتسلسل واحد مثلا من 1 الى 100 

فما علاقة الكود بهذا العمود

 

[حسونة حسين]

And cel.Offset(0, -1) = i

دى الخاصه بالعامود a

يمكنك حذفها

[علي المصري]

في ١٤‏/١٢‏/٢٠٢١ at 14:43, hassona229 said:

دى الخاصه بالعامود a

يمكنك حذفها

اذا تم حذفها يعطي اسم واحد مكرر بعدد طلاب الفصل

شكرا لاهتمام حضرتك

[حسونة حسين]

جرب هذا التعديل اخى الكريم 

Option Explicit
Sub MyStuNames()
    Dim Rng1 As Worksheet, Rng2 As Worksheet, T As String, Y As Integer, X As Double, Cel As Range, i As Integer
    Application.ScreenUpdating = False
    Set Rng1 = Worksheets("StudNames"): Set Rng2 = Worksheets("Analysis")
    T = Rng2.[AB1]
    X = Application.CountIf(Rng1.Range("B:B"), T)
    Y = IIf(Range("LangCod") = 2, 5, 4)
    Rng2.Range("B8:C42") = Empty
    i = 1
    For Each Cel In Rng1.Range("B2:B" & Rng1.Cells(Rows.Count, 2).End(xlUp).Row)
        If Cel = T Then
            Rng2.Cells(7 + i, "B").Value = i
            Rng2.Cells(7 + i, "C").Value = Rng1.Cells(Cel.Row, Y).Value
            i = i + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub