تصحيح الخطأ في كود قوائم الفصول

[2saad]

السادة اعضاء المنتدي الذي تعلمنا منه كثيرا

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

انتبه من فضلك ... مشاركة مكررة .. تــــم بالفعل حذف المشاركة الأخرى

 هذا هو الكود وهذه رسالة الخطأ الذى تظهر , يجب عليك التوضيح هكذا

Sub Test()
    Dim a, ws As Worksheet, sh As Worksheet, s As String, i As Long, ii As Long, k As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("مجمع الشيتات")
        Set sh = ThisWorkbook.Worksheets("قوائم الفصول")
        With ws
            a = .Range("C10:P" & .Cells(Rows.Count, 3).End(xlUp).Row).Value
            a = Application.Index(d, Evaluate("ROW(4:" & UBound(d, 4) & ")"), [{3,4,5,7,9,11,12,15,16}])
            ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
            s = sh.Range("F4").Value
            sh.Range("C10").CurrentRegion.Offset(1).ClearContents
            If IsEmpty(s) Then Exit Sub
            sh.Columns(3).NumberFormat = "@"
            sh.Columns(8).NumberFormat = "@"
            For i = LBound(a, 1) To UBound(a, 1)
                If a(i, 7) = s Then
                    k = k + 1
                    b(k, 1) = k
                    For ii = 3 To UBound(a, 2)
                        b(k, ii) = a(i, ii)
                    Next ii
                End If
            Next i
            If k > 0 Then sh.Range("C10").Resize(k, UBound(d, 4)).Value = b
             End With
         End Sub

مجمع الشيتات.rar

[ابراهيم الحداد]

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

اقتراح بدون تجربة لضيق الوقت

فى هذا السطر من الكود

         a = .Range("C10:P" & .Cells(Rows.Count, 3).End(xlUp).Row).Value

استبدل حرف اول السطر حرف  a بحرف d

و الله اعلى و اعلم

[2saad]

شكرا لرد حضرتك

ولكن لم ينفع

[ابراهيم الحداد]

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

اذن لا مناص من استخدام الكود التالى

Sub TrData()
Dim ws As Worksheet, Sh As Worksheet
Dim LR As Long, i As Long, j As Integer, p As Long
Dim Arr As Variant, Tmp As Variant, Fsl As String
Application.ScreenUpdating = False
Set ws = Sheets("قوائم الفصول")
Set Sh = Sheets("مجمع الشيتات")
LR = Sh.Range("E" & Rows.Count).End(3).Row
ws.Range("C" & ws.Range("E" & Rows.Count).End(3).Row + 1) = ""
Fsl = ws.Range("F4").Value
If IsEmpty(Fsl) Then Exit Sub
Arr = Sh.Range("C10:P" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 13) = Fsl Then
p = p + 1
For j = 1 To 8
Tmp(p, j) = Arr(i, Choose(j, 1, 2, 3, 5, 7, 9, 10, 13))
Tmp(p, 1) = p
Next
End If
Next
If p > 0 Then ws.Range("C10").Resize(p, UBound(Tmp, 2)).Value = Tmp
Application.ScreenUpdating = True
End Sub

 

[2saad]

بارك الله فيك واكثر الله من امثالك ..بس لي ملحوظة ...عند الترحيل في عمود الفصل مكتوب ارقام وليس اسم الفصل

 

 

[ابراهيم الحداد]

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

يجب تغيير تنسيق عمود الفصل الى  Text

[أ / محمد صالح]

بعد إذن الجميع

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

الخطأ في نقل الكود وليس الكود الأصلي

وينتج هذا الخطأ عن عدم فهم دلالات الأرقام والمتغيرات في الكود

بالتوفيق

مجمع الشيتات.xlsm