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

[موضوع مميز]شرح عمل شيت كنترول ( درة أعمال العلامة عبد الله باقشير)[مثبت]

محمدي عبد السميع
 مشاركة

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

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

استخراج الشهادات بطريقه العلامه عبد الله باقشير 

''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله
''استخراج شهادات الطلاب     الهدف من الكود


'رقم اول صف للشهادة
Const FirstRow As Integer = 7
'-------------------------------
'عدد صفوف الشهادة
Const CountRow As Integer = 11
'-------------------------------
'عدد اعمدة الشهادة التي تريد اظهارها في الطباعة
Const CountColumn As Integer = 13
'-------------------------------
Const Range_Index As String = "A7"
'-------------------------------
Dim KH_Boolean As Boolean, KH_Test As Boolean
Sub الكل()
Call kh_Test_Fill(Sheet3.Range("D1"))
If KH_Test Then GoTo 1
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub الناجحين()
Call kh_Test_Fill(Sheet3.Range("G1"))
If KH_Test Then GoTo 1
Call kh_Nd("ناجح")
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub دور_ثاني()
Call kh_Test_Fill(Sheet3.Range("J1"))
If KH_Test Then GoTo 1
Call kh_Nd("دور ثاني")
Sheet3.PrintPreview
1 Application.ScreenUpdating = True
End Sub
Sub kh_Test_Fill(MyCel As Range)
Dim R As Integer, RR As Long
KH_Boolean = True: kh_Delete: KH_Boolean = False
KH_Test = False
If Not IsNumeric(MyCel) _
Or (IsNumeric(MyCel) And MyCel.Value = 0) Then _
MsgBox MyCel.Offset(0, -1) & Chr(10) & Chr(10) & MyCel, 524288 + 1048576 + 16, "بيانات غير متوفرة": KH_Test = True: GoTo 1

R = MyCel.Value
With Sheet3
    .Range(Range_Index).Value = 1
    If R = 1 Then GoTo 1
    RR = (R * CountRow)
    Call kh_AutoFill(.Rows(FirstRow).Resize(CountRow), .Rows(FirstRow).Resize(RR), .Range("B" & FirstRow).Resize(RR, CountColumn).Address)
End With
1
End Sub
Sub kh_AutoFill(SourceRange As Range, fillRange As Range, Kh_PrintArea As String)
SourceRange.AutoFill fillRange, xlFillDefault
Sheet3.PageSetup.PrintArea = Kh_PrintArea
End Sub
Sub kh_Nd(Nd As String)
Dim MyRng As Range
Dim R As Integer, RR As Long
Set MyRng = Range("data").Columns(46)
RR = FirstRow
With MyRng
    For R = 1 To .Rows.Count
        If .Cells(R, 1) = Nd Then
            Sheet3.Cells(RR, 1) = R
            RR = RR + CountRow
        End If
    Next
End With
End Sub
Sub kh_Delete()
Dim T As Long
Application.ScreenUpdating = False
With Sheet3
    .Range(Range_Index).ClearContents
    T = .UsedRange.Rows.Count
    .Rows(FirstRow + CountRow).Resize(T).Delete
End With
If KH_Boolean Then GoTo 1
Application.ScreenUpdating = True
MsgBox "تم مسح الشهادات", vbMsgBoxRight, "الحمد لله"
1 End Sub

 

استخراج شهادات بطريقه العلامه عبد الله باقشير.rar

كود لفرز البيانات بمعيار الفصل

وموجود ايضا بالملف السابق اردت ان اضع الاضواء عليه 

Sub KH_Sort()
''هذا الكود للعالم العلامه والبحر الفهامه عبد الله باقشير حفظه الله
''فرز بيانات الطلاب بمعيار الفصل   الهدف من الكود

Dim MyShap As Shape
Dim T As Integer
Set MyShap = Sheet4.Shapes("Kh_Num")
If MyShap.ControlFormat.Value = 1 Then T = 2 Else T = 1
    Range("data").Sort Range("AU12"), T
End Sub

 

  • الردود 236
  • Created
  • اخر رد

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

محمدي عبد السميع
محمدي عبد السميع

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

محمدي عبد السميع
محمدي عبد السميع

كودان احدهما لمعاينة الطباعه والآخر لمعاينة الطباعة مع امكانية الطباعه بارك الله لنا ولكم آمين معاينة طباعة.rar معاينة طباعة مع امكانية الطباعه.rar

asdhamdey
asdhamdey

=IF(B5="";"";IF(AND((COUNTIFS(C5:AX5;"غائب")=0);(COUNTIFS(C5:AX5;"دون المستوى")=0));"ناجح";"راسب")) انظر الى المعادلة   (هذا العمل للمحترم الاستاذ محمد ابو البراء ) لو لاحظنا في هذه الدالة

Posted Images

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

استخراج القيم الفريده

  

Const StudentData As String = "بيانات الطلبة"
Const TopStudents As String = "الاوائل"

Private Sub Worksheet_Activate()

Application.DisplayAlerts = False
Sheets(TopStudents).Range("S:S").ClearContents

Sheets(StudentData).Range("V5:V1000").AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheets(TopStudents).Range("S8"), unique:=True
Sheets(TopStudents).Range("S9").Value = "الكل"

With Sheets(TopStudents).Range("S8")
        .Interior.Pattern = xlSolid
        .Interior.Color = 65535
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .Font.Size = 16
End With

With Sheets(TopStudents).Range("S9:S100")
        .Interior.Pattern = xlSolid
        .Interior.ColorIndex = 0
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .Font.ColorIndex = 0
        .Font.Size = 16
End With

Macro1
Application.DisplayAlerts = True
End Sub

 

فلترة متقدمة.zip

كشوف المناداه وارقام الجلوس يصلح للثانوي العام

 

 

كشوف المناداه وارقام الجلوس للثانوي العام.rar

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

قوائم منسدله دون تكرار بالمعادلات 

=INDEX(Feuil1!$A:$A;MIN(IF(COUNTIF(B$2:B2;List)=0;ROW(List))))&""

 

قوائم منسدلة دون تكرار ودون فراغات.rar

 

 

==========================================

معادله مطاطيه لاستخراج القيم الفريده 

=INDEX('بيانات الطلبة'!$V$7:$V$212;MATCH(0;COUNTIF($S$9:$S9;'بيانات الطلبة'!$V$7:$V$212);0))

 

قائمة مطاطة خاليه من ظهور علامات الخطأ.rar

  • 2 months later...
cat101

cat101

قام بنشر
قام بنشر

روابط لكنترولات مفيده
نسخة التعليم الإبتدائى
من الميديا فاير

نسخة التعليم الإعدادى
من الميديا فاير

نسخة التعليم الثانوى العام
من الميديافاير

نسخة التعليم الصناعى
من الميديا فير

نسخة التعليم التجارى
من الميديا فير

نسخة التعليم الفندقى
من الميديا فير

نسخة التعليم الإبتدائى للأزهر الشريف
من الميديا فير


البرنامج لا يفتح الا من خلال كلمة مرور (1) يمكن تغييرها كيفما تشاء
الانتقال من مستوى صلاحية الى اخر يتم من خلال كلمة مرور اخرى (1)
يمكن ايضا تغييرها فى أى وقت

فمثلاً يمكن تفعيل قائمة (جلوس وسرى) وقائمة (مطبوعات) باتباع الاتى :
اعدادات - تغيير الصلاحية - اختيار رئيس الكنترول - وضع كلمة المرور:1 ثم الضغط على موافق
 

  • Like 1
  • 3 weeks later...
ابن بنها

ابن بنها

قام بنشر
قام بنشر

كنترولات تجربه مفيده وجدتها على صفحات النت

http://up.top4top.net/f-328srtp91-rar.html

http://up.top4top.net/downloadf-328zrpn61-rar.html

http://up.top4top.net/downloadf-3282bt3u1-rar.html

http://up.top4top.net/downloadf-328m849b1-rar.html

http://up.top4top.net/downloadf-3285m2dd2-rar.html

http://up.top4top.net/downloadf-328e6ccy1-rar.html

  • Like 1
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

توزيع لجان الطلبه كل 4 لجان في صفحه من الروائع

http://up.top4top.net/downloadf-3402c7sr1-rar.html

  

Option Explicit
Option Base 1
Dim myc As Range
Dim myrang2 As Range
Sub PrepareCol()
Application.ScreenUpdating = False
' توزيع مبدئي
setmyrng
aly_Clear
'Sheets("اللجان").Cells.Clear
'رقم آخر صف فى جدول المدى من إلى
Dim LR_Info  As Long
' آخر صف فى عمود البيانات شيت 1
Dim LastRow As Long
' آخر صف فى شيت 2
Dim LastRow2 As Long
'الخلية إلى فى الجدول و الخلية من
Dim ToRow As Long, FromRow As Long
'  مصفوفة من 3 عناصر لتخزين رقم العمود الجديد
Dim LR(0 To 3) As Long
' جدول المدى
Dim TableInfo()
Dim i As Long, K As Integer
Dim MyRg As Range
Dim mycl As Range
Dim myallrange As Range
Dim y As Long
Dim x As Integer
Dim z As Long
Dim m As Long
Dim s As Integer
Dim T As Integer
Dim o As Long, ss As Integer, g As Long, h As Long, u As Long, f_end As Long
s = Application.CountA(ورقة2.Range("J9:J500"))
ss = Application.RoundUp(s / 4, 0)
Dim myrase As Range, mydall As Range, myarwa As Range, myaly As Range
'Sheets("اللجان").Select
'Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
 
    Sheets("data").Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    LR_Info = Cells(Rows.Count, Range("إلى").Column).End(xlUp).Row
    LastRow2 = Sheets("اللجان").Range("B" & Rows.Count).End(xlUp).Row + 1
    'توزيع أرقام الجلوس حسب بداية الترقيم
    Set myallrange = Sheets(1).Range("b2:b" & LastRow)
   ' For Each mycl In myallrange
         ' mycl.Offset(, 1).Value = Range("e12") + y
        'y = y + 1
        'Next mycl
    
    Range(Range("إلى").Offset(1), Cells(LR_Info, (Range("إلى").Column) + 1)).Select
    ' حدود الجدول لاحظ تحديد مدى الجدول باستخدام رينج و سيلس معا
    TableInfo = Range(Range("من").Offset(1), Cells(LR_Info, (Range("من").Column) + 1))
    K = 0
    x = 7
    ' UBound لمعرفة طول المصفوفة أو الجدول
    On Error Resume Next
    
     For m = 1 To ss
    For i = 1 To UBound(TableInfo())
        ToRow = TableInfo(i, 2)
        FromRow = TableInfo(i, 1)
        
          Set MyRg = Range("e6:e8")
        MyRg.Copy Destination:=Sheets("اللجان").Cells(LastRow2, K * 4 + 1)
        Sheets("اللجان").Cells(LastRow2 + 3, K * 4 + 1).Value = "لجنة رقم :" & i
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Value = " من " & FromRow + Sheets("data").Range("e12") - 1
        'Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(, 1) = FromRow + Sheets("data").Range("e12").Value - 1
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(, 2) = "العدد "
        Sheets("اللجان").Cells(LastRow2 + 4, K * 4 + 1).Offset(1, 2) = ToRow - FromRow + 1
        Sheets("اللجان").Cells(LastRow2 + 5, K * 4 + 1).Value = " إلى " & ToRow + Sheets("data").Range("e12") - 1
        
        'Sheets("اللجان").Cells(LastRow2 + 5, K * 4 + 1).Offset(, 1) = ToRow + Sheets(1).Range("e11").Value - 1
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 1).Value = " م "
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 2).Value = " اسم الطالب "
        'Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 3).Value = "رقم الجلوس"
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 1).Offset(, 2) = "رقم الجلوس"
        Sheets("اللجان").Cells(LastRow2 + 6, K * 4 + 4).Value = "الديانة"
          Set MyRg = Range(Cells(FromRow + 1, "B"), Cells(ToRow + 1, "d"))
        MyRg.Copy Destination:=Sheets("اللجان").Cells(LastRow2 + x, K * 4 + 2)
        Set myrase = Range("rase")
        Set mydall = Range("dell")
        Set myarwa = Range("anas")
        myrase.Copy
        Sheets("اللجان").Cells(LastRow2, K * 4 + 1).PasteSpecial xlPasteFormats
        
        'التسلسل
        
        For z = 1 To ToRow - FromRow + 1
            Sheets("اللجان").Cells(LastRow2 + z + 6, K * 4 + 1).Value = z
            
            myarwa.Copy
         Sheets("اللجان").Cells(LastRow2 + z + 6, K * 4 + 1).PasteSpecial xlPasteFormats
            
            Next z
            
            Set MyRg = Range("e10")
        Sheets("اللجان").Cells(LastRow2 + x - 1 + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس الكنترول " & "/" & MyRg
        Sheets("اللجان").Cells(LastRow2 + x + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس لجنة الامتحان  " & "/" & MyRg.Offset(1, 0)
        
        'Sheets("اللجان").Cells(LastRow2 + x + (ToRow - FromRow + 2), K * 4 + 2) = "رئيس لجنة الامتحان  " & "/" & MyRg.Offset(1, 0)
        
        mydall.Copy
        Sheets("اللجان").Cells(LastRow2 + x - 1 + (ToRow - FromRow + 2), K * 4 + 1).PasteSpecial xlPasteFormats
         
              
              K = K + 1
        K = K Mod 4
        LR(K) = LastRow2 + x + ToRow - FromRow + 3
        If (K = 0) Then LastRow2 = Application.Max(LR(0), LR(1), LR(2), LR(3))
        Sheets("اللجان").Select
        ActiveWindow.View = xlPageBreakPreview
        'g = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row + 1
        'h = Sheet1.Cells(Rows.Count, 6).End(xlUp).Row + 1
        If (K = 0) Then
        'If LastRow2 = 2 Then GoTo 1
        'If h > g Then
        Set ActiveSheet.HPageBreaks(m).Location = Range("A" & LastRow2)
        'Else
        'Set ActiveSheet.HPageBreaks(m).Location = Range("A" & g)
        m = m + 1
        End If
      
1      Sheets("data").Select
    Next i
   Next m
    With Sheets("اللجان")
    o = .Cells(Rows.Count, 2).End(xlUp).Row
    g = .Cells(Rows.Count, 6).End(xlUp).Row
    u = .Cells(Rows.Count, 10).End(xlUp).Row
    h = .Cells(Rows.Count, 14).End(xlUp).Row
        .Range("a:p").ReadingOrder = xlRTL
        .Range("a:p").Font.Bold = True
        .Range("a:p").Font.Size = 13
        .Range("a:p").Font.Name = "Arial"
       f_end = Application.Max(o, g, u, h)
       .PageSetup.PrintArea = .Range("A2:p" & f_end).Address
        'If o > g Then
        '.PageSetup.PrintArea = .Range("A2:p" & o).Address
        'Else
        '.PageSetup.PrintArea = .Range("A2:p" & g).Address
        'End If
    End With
    Sheets("اللجان").Select
    ActiveWindow.View = xlNormalView
    Range("A1").Activate
    Set MyRg = Nothing
    Set myallrange = Nothing
   Sheets("data").Select
   Range("A1").Activate
End Sub
Sub dsds()
Dim LastRow2 As Long
LastRow2 = Sheets("اللجان").Range("B" & Rows.Count).End(xlUp).Row + 1
'Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
Sheets("اللجان").Range(Range("a1:h" & LastRow2), Range("a1:h" & LastRow2).End(xlDown)).Clear
End Sub

Sub aly_Clear()
    Dim y As Integer
    Application.ScreenUpdating = False
    With Sheet1
            
        y = .UsedRange.Rows.Count + 100
        .Range("A2:p" & y).Clear
        .ResetAllPageBreaks
        .PageSetup.Zoom = 92
        .PageSetup.PrintArea = .Range("A2:p10000").Address
        Range("A1").Activate
    End With
End Sub
Sub jhjjhjh()
'On Error Resume Next
Dim o As Integer, b As Integer, d As Range, dd As Integer, g As Integer, h As Integer
 With Sheets("اللجان")
    o = .Cells(Rows.Count, 2).End(xlUp).Row
    g = .Cells(Rows.Count, 6).End(xlUp).Row
        .Range("a:k").ReadingOrder = xlRTL
        .Range("a:k").Font.Bold = True
        If o > g Then
        .PageSetup.PrintArea = .Range("A2:H" & o).Address
        Else
        .PageSetup.PrintArea = .Range("A2:H" & g).Address
        End If
    End With

End Sub
Sub muuyy()
'On Error Resume Next
Dim E As Integer, b As Integer, d As Integer, dd As Integer, gg As Integer, hh As Integer
'g = Application.CountA(ورقة2.Range("J9:J500"))
b = 9
E = 2
d = Application.RoundUp(b / 2, 0)


End Sub
Sub ads222s()
With ورقة1.Range("a1:p300")
           .ShrinkToFit = True
           .ReadingOrder = xlRTL   ' اتجاه النص
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
         End With
With ورقة1.Range("a1:p300").Font
        .Name = "Arial"
        .FontStyle = "غامق"
        .Size = 13
End With

End Sub

  

Sub setmyrng()
Sheets("data").Range("h9:i500").ClearContents
Sheets("data").Range("h9") = 1
Range("i9") = Range("j9")
Range("h10") = Range("i9") + 1
Dim myc As Range
Dim myrang2 As Range

    Set myrange2 = Range("j10:j500")
    For Each myc In myrange2
    
    If myc <> "" Then
    myc.Offset(0, -1) = (myc.Value + myc.Offset(0, -2).Value) - 1
    If myc.Offset(1, 0) <> "" Then
    myc.Offset(1, -2) = myc.Offset(0, -1) + 1
    'myc.Offset(1, -2) = myc.Offset(0, -1) + 1
    End If
    End If
    Next myc
    
End Sub

 

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

http://up.top4top.net/downloadf-340w1meo1-rar.html 

'هذا الكود للمبدعه ساجده العزاوي
'الهدف من الكود هو وضع دوائر حمراء حول الدرجات الضعيفه بمعيارك
'

Dim c As Range
 Dim o As Shape
 Dim N As Integer
 

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("c1:i1")) Is Nothing Then
GoTo 1
Else
1:
N = Target.Column
Select Case N

Case 3
 A = [C1].Value
 
 Case 4
  A = [D1].Value
 
 Case 5
  A = [E1].Value
 
 Case 6
  A = [F1].Value
  
 Case 7
  A = [G1].Value
 
 Case 8
  A = [H1].Value

  Case 9
  A = [I1].Value
 
End Select
 
       For Each c In Range(Cells(2, N), Cells(8, N))
       If c.Value < A And A <> "" Then
         Set o = Sheets("younes").Shapes.AddShape(msoShapeOval, _
               c.Left, c.Top, c.Width, c.Height)
           o.Fill.Visible = msoFalse
           o.Line.ForeColor.SchemeColor = 10
           o.Line.Weight = 1.25
           o.Name = "S" & c.Address
        Else
   Dim shp As Shape
   For Each shp In ActiveSheet.Shapes
       If shp.Name Like "S" & c.Address Then shp.Delete
    Next
    End If
   Next
   
End If


  End Sub

 

=======================================================================

تلوين خلايا بشرط

http://up.top4top.net/downloadf-3401oiyo1-rar.html

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

ملف لتوزيع اللجان

 

طباعـــــــــــــه صفحات.rar

استدعاء بيانات بطريقه سريعه جدا 


'''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
Sub DOR_tan()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو فلترة البيانات
''شرح الكود
''
    Dim myArray, lr, X, targt, targt1, targt2, targtN
    Dim SERCH As Worksheet, DATA As Worksheet
    '____________________________________________
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت  المصدر
    Set SERCH = Worksheets("كشف الدور الثاني")    'اسم الشيت الهدف
    '____________________________________________
    Range("A8:R1000").Clear
    'النطاقات متغيره
    Range("B7:R7").AutoFill Destination:=Range("B7:R" & Range("A4").Value + 6), Type:=xlFillDefault
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2  'اخر صف به بيانات
    'رقم عمود البدايه اللي بعد المسلسل
  '  متغير
    SERCH.Range("C7:N" & SERCH.Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = "له* دور ثان في"    'معيار البحث
    
     'نطاق قاعدةالبيانات المصدر الذي سيتم البحث فيه
    myArray = DATA.Range("A7:EF" & lr)
    '____________________________________________
    'عدد الاعمده في الجدول في صفحه الهدف
    ReDim y(1 To lr, 1 To 13)
    For X = 1 To lr - 6
        If targt = "" Then Exit Sub
        
        'رقم عمود معيار البحث
        If myArray(X, 101) Like targt & "*" Then
            rw = rw + 1
            'For ww = 1 To 102
              '  Y(rw, ww) = myArray(X, ww)
          '  Next ww
    'العمود التاني بعد المسلسل
          y(rw, 1) = myArray(X, 2)
          
              'العمود الثالث بعد المسلسل
          y(rw, 2) = myArray(X, 3)
          
              'العمود الرابع بعد المسلسل
          y(rw, 3) = myArray(X, 13)
          
              'العمود الخامس بعد المسلسل
          y(rw, 4) = myArray(X, 22)
          
              'العمود السادس بعد المسلسل وهكذا
          y(rw, 5) = myArray(X, 31)
          
          y(rw, 6) = myArray(X, 40)
          y(rw, 7) = myArray(X, 51)
          y(rw, 8) = myArray(X, 52)
          y(rw, 9) = myArray(X, 82)
          y(rw, 10) = myArray(X, 101)
          y(rw, 11) = myArray(X, 102)
        '  Y(rw, 12) = myArray(X, 110)
         ' Y(rw, 13) = myArray(X, 111)
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 3).End(xlUp)(2, 1).Resize(rw, 13).Value = y()
End Sub

 

استدعاء بيانات بطريقه سريعه.rar

ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

كشوف لجان متميزه 

Sub PrintFrom8_To_()
MsgBox "للحصول على طباعة كاملة يجب عدم ملامسة الماوس أو لوحة المفاتيح أثناء الطباعة"
Dim I As Integer
For I = Range("t7") To Range("u7") Step 2
If I <= Range("u7") Then
Range("e5") = I
ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate:=True
End If
Next I
Range("e5").Select
End Sub

 

كشوف لجان متميزه.rar

  • Like 2
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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


×
×
  • اضف...

Important Information

  I accept