تعديل كود

[علي المصري]

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

الكود التالي يقوم بجلب الاسماء من  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.xlsbFetching info...

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

[علي المصري]

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

1111.xlsbFetching info...

[علي المصري]

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

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

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

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

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

1111.xlsbFetching info...

[حسونة حسين]

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

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

 

[علي المصري]

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

عند كتابة  قيمة الخلية 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 يعطيني البيانات أو اذا وجده اي حالة من الحالتين

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

Expand  

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

 

  اقتباس

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

Expand  

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

[علي المصري]

  في 14‏/12‏/2021 at 08:57, محي الدين ابو البشر 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

هكذا؟

Expand  

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

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

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

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

 

  في 14‏/12‏/2021 at 10:26, hassona229 said:

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

Expand  

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

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

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

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

 

[حسونة حسين]

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

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

يمكنك حذفها

[علي المصري]

  في 14‏/12‏/2021 at 10:43, hassona229 said:

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

يمكنك حذفها

Expand  

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

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

[حسونة حسين]

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

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