التعديل على كود للعلامه الكبير _ عبدالله باقشير

[ابو الآء]

السلام عليكم

الرجاء التعديل على كود طباعه الشهادات

بما يناسب منطلباتى 

'***********************************************
'***********************************************
'     اسم ورقة الشهادات
Const ShName As String = "الشهادة"
'     رقم اول صف للشهادة
Const FirstRow As Integer = 5
'     عدد صفوف الشهادة
Const CountRow As Integer = 13
'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة
Const CountColumn As Integer = 20
' خلية موقع الطالب  لمعادلات الشهادة
Const Range_Index As String = "B13"
'=====================================
'     اسم ورقة البيانات
Const sh As String = "شيت "
' نطاق ناجح دور ثاني في ورقة البيانات
Const MyND As String = "da12:da1000"
' نطاق الاسماء في ورقة البيانات
Const MyNSearch As String = "m12:m1000"

'=====================================
'   خلية عدد كل المتقدمين
Const CountAll As String = "D2"
'    خلية عدد الناجحين
Const CountNA As String = "ناجح"
اريدها هنا الخليه e3
'   كلمة البحث عن الناجحين
Const NA_G As String = "F2"
'   خلية عدد دور ثاني
Const CountDT As String = "H2"
'   كلمة البحث عن دور ثاني
Const DT_G As String = "دور ثان"
'************************************************
'************************************************

Dim KH_Test As Boolean
Dim MySheet As Worksheet
Sub الكل()
Application.ScreenUpdating = False
kh_ClearContents
With MySheet
    .Range(Range_Index).Value = 1
    Call kh_Test_Fill(.Range(CountAll))
    If KH_Test Then .PrintPreview Else .Range(Range_Index).ClearContents
End With
Application.ScreenUpdating = True
End Sub
Sub الناجحين()
Application.ScreenUpdating = False
kh_ClearContents
With MySheet
    Call kh_Test_Fill(.Range(CountNA))
    If KH_Test Then Call kh_Nd(NA_G): .PrintPreview
End With
Application.ScreenUpdating = True
End Sub
Sub دور_ثاني()
Application.ScreenUpdating = False
kh_ClearContents
With MySheet
    Call kh_Test_Fill(.Range(CountDT))
    If KH_Test Then Call kh_Nd(DT_G): .PrintPreview
End With
Application.ScreenUpdating = True
End Sub
Sub Item_Search()
Dim NN As Integer, R As Integer, C As Integer, RR As Long
NN = form_Search.CM_ListAdd.ListCount
Application.ScreenUpdating = False
kh_ClearContents
With MySheet
    If NN = 1 Then
        .Range(Range_Index).Value = form_Search.CM_ListAdd.List(0, 1)
    Else
        Call kh_AutoFill(NN)
        RR = .Range(Range_Index).Row
        C = .Range(Range_Index).Column
        For R = 0 To NN - 1
            .Cells(RR, C) = form_Search.CM_ListAdd.List(R, 1)
            RR = RR + CountRow
        Next
    End If
    .PrintPreview
End With

Unload form_Search
Application.ScreenUpdating = True
End Sub
Sub kh_Test_Fill(MyCel As Range)
If IsNumeric(MyCel) And MyCel.Value > 0 Then
    KH_Test = True
    If MyCel.Value <> 1 Then Call kh_AutoFill(MyCel.Value)
Else
    KH_Test = False
    MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & MyCel, 524288 + 1048576 + 16, "بيانات غير متوفرة"
End If
End Sub
Sub kh_AutoFill(R As Integer)
Dim SourceRange As Range, fillRange As Range
Dim RR As Long
RR = (R * CountRow)
With MySheet
    Set SourceRange = .Rows(FirstRow).Resize(CountRow)
    Set fillRange = .Rows(FirstRow).Resize(RR)
    SourceRange.AutoFill fillRange, xlFillDefault
    .PageSetup.PrintArea = .Range("B" & FirstRow).Resize(RR, CountColumn).Address
End With
End Sub
Sub kh_Nd(Nd As String)
Dim MyRng As Range
Dim R As Integer, C As Integer, RR As Long
Set MyRng = Sheets(sh).Range(MyND)
With MySheet
    RR = .Range(Range_Index).Row
    C = .Range(Range_Index).Column
End With
With MyRng
    For R = 1 To .Rows.Count
        If .Cells(R, 1) = Nd Then
            MySheet.Cells(RR, C) = R
            RR = RR + CountRow
        End If
    Next
End With
End Sub
Sub kh_ClearContents()
Dim T As Long
Set MySheet = Sheets(ShName)
With MySheet
    .Range(Range_Index).ClearContents
    T = .UsedRange.Rows.Count
    .Rows(FirstRow + CountRow).Resize(T).Delete
    Application.GoTo .Range(Range_Index), True
End With
End Sub
Sub kh_Delete()
Application.ScreenUpdating = False
kh_ClearContents
Application.ScreenUpdating = True
ThisWorkbook.Save
MsgBox "تم مسح الشهادات وحفظ العمل", vbMsgBoxRight, "الحمد لله"
End Sub
Sub معاينة()
ورقة4.PrintPreview
End Sub
Sub Kh_Search()
Load form_Search
With form_Search
    .Tag = sh
    .CM_TextFind.Tag = MyNSearch
    .Show
End With
End Sub

[ابو الآء]

التعديل هناا

' خلية عدد كل المتقدمين
Const CountAll As String = "D2"
' خلية عدد الناجحين
Const CountNA As String = "ناجح"
اريدها هنا الخليه e3
' كلمة البحث عن الناجحين
Const NA_G As String = "F2"
' خلية عدد دور ثاني
Const CountDT As String = "H2"
' كلمة البحث عن دور ثاني
Const DT_G As String = "دور ثان"
'*************************************

[ياسر خليل أبو البراء]

بما أنك تعرف المتغيرات التي يجب أن تتغير فلما لا تغيرها بنفسك

مجرد تساؤل ؟؟!!

جرب غير بنفسك وشوف النتيجة ولو فيه مشكلة ارفق المشكلة

[ابو الآء]

السلام عليكم

اسف اخى حاولت وحظيت رقم الخليه ومش بتدى النتائج المرجوه

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

ولم انجح 

حاول مره كثره

المفروص الخليه e3 بيها قائمه منسدله 

فيها ارقام الفصول

ارجوا المساعده

[ياسر خليل أبو البراء]

أين الملف يا أبو آلاء ؟

[ابو الآء]

 السلام عليكم

اليك الملف اخى بعد نقل الكود الى ملفى 

فى الملف الاصلى عمل معى ولكن نتائج خطاء بعد النقل لا يعمل ايضااا

كلمه المرور

المستخدم 1

الباص 1

فتح الاكواد 1

ابو القاسم.rar

[ياسر خليل أبو البراء]

السلام عليكم

اسف اخى حاولت وحظيت رقم الخليه ومش بتدى النتائج المرجوه

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

ولم انجح 

حاول مره كثره

المفروص الخليه e3 بيها قائمه منسدله 

فيها ارقام الفصول

ارجوا المساعده

بعد النظرة المبدئية على الملف ..

القائمة المنسدلة لتي ذكرتها في الخلية D2 وليست E3

شوف وحاول مرة أخرى

[ابو الآء]

بالفعل استاذى وهى بداخل الكود d2

لكن الكود لا يعمل

[ابو الآء]

لا اله الا الله

محمد رسول الله