اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by ياسر خليل أبو البراء,

الردود الموصى بها

السلام عليكم

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

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

'***********************************************
'***********************************************
'     اسم ورقة الشهادات
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

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information