أكاديمية الصقر للتدريب

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


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





مطلوب طباعة كل كود على حدة

السلام عليكم فى ورقة العمل ( بيان الاستقطاع لاصدار امر الدفع ) عند تحديد الشهر فى الخلية e1 و تحديد الباب فى الخلية j1 ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


03-11-2020 04:47 مساء
صلاح الصغير
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 55
المشاركات : 354
الجنس : ذكر
تاريخ الميلاد : 13-10-1973
يتابعهم : 1
يتابعونه : 4
قوة السمعة : 297
عدد الإجابات: 1
 offline 

السلام عليكم
فى ورقة العمل ( بيان الاستقطاع لاصدار امر الدفع )
عند تحديد الشهر فى الخلية e1  و تحديد الباب فى الخلية j1 يتم استدعاء نتيجة البحث من ورقة التسجيل
و المطلوب زر طباعة لكل رقم تسجيل ضريبى على حدة فى العمود d
مع مراعاة عند وجود رقم تسجيل ضريبى مكرر يتم طباعته جميع سجلاته
و شكرا
 
 
  القيمة المضافة- احمد طلعت.rar   تحميل rar مرات التحميل :(6)
الحجم :(249.556) KB



أفضل إجابة مقدمة من salim وهي:
الحل في الصفحة Result من هذا الملف
الصفحات الباقية تعمل كما كانت في حال تمت الحاجة اليها
الكود

Option Explicit
Dim COL As Collection
Dim Dic As Object
Dim I%, m%, MaxI%, k%, All_rows%, t%
Dim Filer_range As Range
Dim Ky
'+++++++++++++++++++++++++++++++++++++++++
Sub result_Sheet()
Set COL = New Collection
Set Dic = CreateObject("Scripting.Dictionary")
MaxI = Tasjil.Cells(Rows.Count, "I").End(3).Row
If Result.AutoFilterMode Then _
    Result.Range("B7").AutoFilter
t = Result.Range("C7").CurrentRegion.Rows.Count
 If t > 1 Then
  Result.Range("C7").CurrentRegion. _
  Offset(1).Resize(t - 1).Clear
 End If
 For I = 6 To MaxI
    
    With Tasjil
         If .Cells(I, "E") = Result.Range("E1") _
           And .Cells(I, "F") = Result.Range("J1") Then
          COL.Add I
          Dic(.Cells(I, "I").Value) = ""
         End If
     End With
 Next
 m = 8
 If COL.Count = 0 Then
  MsgBox "Data Not Found"
  Exit Sub
 End If
 
 For I = 1 To COL.Count
  Result.Cells(m, 3).Resize(, 8).Value = _
  Tasjil.Cells(COL(I), 3).Resize(, 8).Value
  m = m + 1
 Next
 t = Result.Range("C7").CurrentRegion.Rows.Count
 If t = 1 Then Exit Sub
  With Result.Range("C7").CurrentRegion. _
    Offset(1).Resize(t - 1)
    .Sort key1:=.Cells(1, 8), order1:=1, _
    key2:=.Cells(1, 2), order2:=1, Header:=2
   .Cells(1, 1).Resize(.Rows.Count).Value = _
    Evaluate("row(1:" & .Rows.Count & ")")
    .Columns(1).HorizontalAlignment = 3
    .Borders.LineStyle = 1
    .InsertIndent 1
    .Font.Bold = True
    .Font.Size = 16
  End With

 Result.PageSetup.PrintArea = _
 Result.Range("B3:J" & m - 1).Address
 If Dic.Count = 0 Then Exit Sub
 Set Filer_range = Result.Range("B7").CurrentRegion
For Each Ky In Dic.keys

 If Result.AutoFilterMode Then _
  Filer_range.AutoFilter
  Filer_range.AutoFilter 8, Ky

  Result.PrintPreview
Next
If Result.AutoFilterMode Then _
    Result.Range("B7").AutoFilter
End Sub

الملف 
عرض الإجابة




07-11-2020 08:52 مساء
مشاهدة مشاركة منفردة [1]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 793
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 10
قوة السمعة : 3910
عدد الإجابات: 108
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
وعليكم السلام ورحمه الله وبركاته
اخى الكريم وضع طلبك بالصور
ضع بعض النتائج المتوقعه

09-11-2020 08:18 صباحا
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
1- الكود يظهر المعاينه قبل الطباعة

2- من اجل الطباعة النهائية استبدل في
      الكود عبارة Bayan.PrintPreview الموجودة  بين  علاملات
      الـــ ++++ بعبارة   Bayan.PrintOut

3- الورقة "التسجيل" تحتوي على صف فارغ (رقم5 مخفي)
    لفصل عنواوين الجدول عن بياناته  يرجى عدم الكتابة به

4- الورقة "بيان الاستقطاع لاصدار امر الدفع "تحتوي على صف
     فارغ (رقم8 مخفي)   لفصل عنواوين الجدول عن بياناته  يرجى
     عدم الكتابة به
الكود

Option Explicit
Dim Dic As Object
Dim I%, RoI%, Fix_row%, Act_row%
Dim m%, MaxI%
Dim Rg_T As Range
Dim F_rg As Range
Dim R_ky As Range
Dim Ky
Sub get_data()
Set Dic = CreateObject("Scripting.Dictionary")
MaxI = Tasjil.Cells(Rows.Count, "I").End(3).Row
Set F_rg = Tasjil.Range("I5:I" & MaxI)
 
 For I = 6 To MaxI
  Dic(Tasjil.Cells(I, "I").Value) = vbNullString
 Next
  For Each Ky In Dic.keys
Bayan.Range("b9").CurrentRegion.ClearContents
m = 9
Set R_ky = F_rg.Find(Ky, lookat:=1)
Fix_row = R_ky.Row: Act_row = Fix_row
Do
    Bayan.Cells(m, 2) = m - 8
    Bayan.Cells(m, 3).Resize(, 8).Value = _
    Tasjil.Cells(Act_row, 3).Resize(, 8).Value
    m = m + 1
    Set R_ky = F_rg.FindNext(R_ky)
    Act_row = R_ky.Row
    If Act_row = Fix_row Then Exit Do
Loop
Bayan.PageSetup.PrintArea = Bayan.Range("b3:J" & m - 1).Address
'+++++++++++++++++++
Bayan.PrintPreview
'+++++++++++++++++++++++++
Next Ky
End Sub

الملف مرفق
 
 
 
  Salah_S.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(537.132) KB


10-11-2020 08:43 صباحا
مشاهدة مشاركة منفردة [3]
صلاح الصغير
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 55
المشاركات : 354
الجنس : ذكر
تاريخ الميلاد : 13-10-1973
يتابعهم : 1
يتابعونه : 4
قوة السمعة : 297
عدد الإجابات: 1
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
رائع استاذ سليم
الفكرة صح 100%
بس كده هو بيطبع كل اللى موجود فى ورقة التسجيل
انا كنت عايز اطبع طبقا للمعايير فى الخليتين e1 و j1
و لو امكن يتم العرض فى الجدول للمعايير المحددة ثم الفصل فى الطباعة طبقا للعمود i

10-11-2020 11:17 صباحا
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
تم التعديل

Option Explicit
Dim COL As Collection
Dim I%, My_val
Dim m%, MaxI%

Sub get_data()

Set COL = New Collection
My_val = Bayan.OLEObjects("CMB_1").Object.Value
MaxI = Tasjil.Cells(Rows.Count, "I").End(3).Row
Bayan.Range("C9").CurrentRegion.Clear
 For I = 6 To MaxI
    On Error Resume Next
    With Tasjil
         If .Cells(I, "E") = Bayan.Range("E1") _
             And .Cells(I, "i") = My_val _
             And .Cells(I, "F") = Bayan.Range("J1") Then
          COL.Add I
         End If
     End With
 Next
 m = 9
 If COL.Count = 0 Then
  MsgBox "Data Not Found"
  Exit Sub
 End If
 
 For I = 1 To COL.Count
  Bayan.Cells(m, 2) = m - 8
  Bayan.Cells(m, 3).Resize(, 8).Value = _
  Tasjil.Cells(COL(I), 3).Resize(, 8).Value
  m = m + 1
 Next
 
 With Bayan.Range("C9").CurrentRegion
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Font.Bold = True
  .Font.Size = 16
  .Columns(1).HorizontalAlignment = 3
 End With
 
 Bayan.PageSetup.PrintArea = _
 Bayan.Range("B3:J" & m - 1).Address

End Sub


الملق مرفق
 
 
  Salah_SaGhir.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(372.871) KB


10-11-2020 06:03 مساء
مشاهدة مشاركة منفردة [5]
صلاح الصغير
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 55
المشاركات : 354
الجنس : ذكر
تاريخ الميلاد : 13-10-1973
يتابعهم : 1
يتابعونه : 4
قوة السمعة : 297
عدد الإجابات: 1
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
و الله يا استاذ / سليم
انا اكيد مقدر مجهود حضرتك
بس انا كل اللى انا عايزه بالبلدى عشان مصعبهاش على حضراتكوا انه
1 - احدد الشهر و الباب الموازنى من الخليتين e1 و j10 
2 - و بعدها مباشرة يتم عرض النتيجة
3 - ثم بالظغط على زر طباعة يتم طباعة كل رقم تسجيل ضريبى من المعروض على حدة 
مع مراعاة اذا كان الرقم الضريبى له سجلين مثلا يتم طباعتهم مع بعض
لان بعد تعديل حضرتك هاضطر اختار من الكومبوبوكس الرقم و اطبعه و احيانا يتعارض مع التحديد فى الخليتين لانه متعبى بكل ارقام التسجيل الضريبى
و ده صعب شوية
ارجو العودة للخطوات من 1 الى 3
و شكرا

10-11-2020 07:30 مساء
مشاهدة مشاركة منفردة [6]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مطلوب طباعة كل كود على حدة
تم التعديل
اضغط على الزر المناسب (لأن الماكرو القديم ما زال يعمل اذا اجتجته)
الزر بدون الــ   Combo لا يتعاطى مع الكومبو بوكس 
 للطباعة استبدل   Bayan.PrintPreview    بـــ Bayan.PrintOut

Option Explicit
Dim COL As Collection
Dim I%, m%, MaxI%
Sub Without_combo()
Set COL = New Collection
MaxI = Tasjil.Cells(Rows.Count, "I").End(3).Row
Bayan.Range("C9").CurrentRegion.Clear
 For I = 6 To MaxI
    On Error Resume Next
    With Tasjil
         If .Cells(I, "E") = Bayan.Range("E1") _
           And .Cells(I, "F") = Bayan.Range("J1") Then
          COL.Add I
         End If
     End With
 Next
 m = 9
 If COL.Count = 0 Then
  MsgBox "Data Not Found"
  Exit Sub
 End If
 
 For I = 1 To COL.Count
  Bayan.Cells(m, 2) = m - 8
  Bayan.Cells(m, 3).Resize(, 8).Value = _
  Tasjil.Cells(COL(I), 3).Resize(, 8).Value
  m = m + 1
 Next
 
 With Bayan.Range("C9").CurrentRegion
  .Borders.LineStyle = 1
  .InsertIndent 1
  .Font.Bold = True
  .Font.Size = 16
  .Columns(1).HorizontalAlignment = 3
 End With
 
 Bayan.PageSetup.PrintArea = _
 Bayan.Range("B3:J" & m - 1).Address
 Bayan.PrintPreview
End Sub

الملف يعد التعديل

 
 
 
  Salah_SaGhir_New.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(377.136) KB



الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
مطلوب ، طباعة ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 09:54 صباحا