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

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
أحمد يوسف ali mohamed ali-- لا تميز خلال هذه الفترة YasserKhalil كود للطباعة علي طابعتين في نفس الوقت اكسيل اسئله واجابات


اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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





استدعاء بيانات بشروط

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



17-02-2020 04:43 مساء
سعد عابد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 100
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
قوة السمعة : 114
الاعجاب : 3
 offline 
السلام عليكم 
استدعاء قيد محاسبى الشرط الاساسى رقم القيد
وقد كتبت الكود ويعمل بكفاءه
ولكن 
اريد اضافة شروط اخرى 
اذا كان اسم الحساب متشابه سواء مدين او دائن لا يتكرر ويجمع المبلغ 
يوجد ثلاث امثلة للنتائج المستهدفه فى الملف
اشكركم
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  استدعاء قيد.xlsb   تحميل xlsb مرات التحميل :(5)
الحجم :(26.289) KB





20-02-2020 10:04 مساء
مشاهدة مشاركة منفردة [1]
سعد عابد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 100
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
قوة السمعة : 114
الاعجاب : 3
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
اخوتى توصلت للمطلوب
يتبقى شئ واحد
هو ان اذا كان الحساب مكرر يتوقف الكود

Sub kid()
Dim Sh As Worksheet, ws As Worksheet, C As Range
Dim LR As Long, i As Long
'''''''''''''''''''''''''''''
Set ws = Sheet1: Set Sh = data2
'''''''''''''''''''''''''''''''''''
ws.Range("a6:i1000").ClearContents
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
LR = Sh.Range("c" & Rows.Count).End(xlUp).Row
i = 5
For Each C In Sh.Range("c5:c" & LR)
If C.Value = ws.Range("g2").Value Then
i = i + 1
ws.Cells(i, "B") = C.Offset(0, 3)
ws.Cells(i, "C") = C.Offset(0, 2)
ws.Cells(i, "D") = "=SUMIFS(ÞíæÏ!C[3],ÞíæÏ!C[-1],R2C7,ÞíæÏ!C[6],RC[3])"
ws.Cells(i, "F") = C.Offset(0, 6)
ws.Cells(i, "G") = C.Offset(0, 7)
ws.Cells(i, "i") = C.Offset(0, 9)
End If: Next
ws.Cells(i + 1, "h") = "Çáì ÍÜ //"
''===================================

ii = i + 1
For Each Cc In Sh.Range("c5:c" & LR)
If Cc.Value = ws.Range("g2").Value Then
ii = ii + 1
ws.Cells(ii, "B") = Cc.Offset(0, 3)
ws.Cells(ii, "C") = Cc.Offset(0, 2)
ws.Cells(ii, "E") = "=SUMIFS(ÞíæÏ!C[3],ÞíæÏ!C[-2],R2C7,ÞíæÏ!C[6],RC[3])"
ws.Cells(ii, "F") = Cc.Offset(0, 6)
ws.Cells(ii, "h") = Cc.Offset(0, 8)
ws.Cells(ii, "i") = Cc.Offset(0, 9)
End If: Next
''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
 
 
  استدعاء قيد.xlsb   تحميل xlsb مرات التحميل :(0)
الحجم :(21.056) KB


أثارت هذه المشاركة إعجاب: YasserKhalil،



21-02-2020 11:33 صباحا
مشاهدة مشاركة منفردة [2]
سعد عابد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 100
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
قوة السمعة : 114
الاعجاب : 3
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
الحمد لله
Sub kidserch()
Dim Sh As Worksheet, ws As Worksheet
Dim LR, h, g, i As Long
'''''''''''''''''''''''''''''
Set ws = sheet9: Set Sh = data7
'''''''''''''''''''''''''''''''''''
ws.Range("a6:i1000").ClearContents
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
LR = Sh.Range("b" & Rows.Count).End(xlUp).Row
i = 5
For h = 5 To LR
If Sh.Cells(h, "d").Value = ws.Range("g2").Value And Sh.Cells(h, "m").Value <> ws.Cells(i, "g").Value Then
i = i + 1
ws.Range("d2").Value = Sh.Cells(h, 7)
ws.Cells(i, "B") = Sh.Cells(h, 9)
ws.Cells(i, "C") = Sh.Cells(h, 8)
ws.Cells(i, "D") = "=SUMIFS(ÞíæÏ!C[6],ÞíæÏ!C,R2C7,ÞíæÏ!C[9],RC[3])"
ws.Cells(i, "F") = Sh.Cells(h, 12)
ws.Cells(i, "G") = Sh.Cells(h, 13)
ws.Cells(i, "i") = Sh.Cells(h, 19)
End If: Next
ws.Cells(i + 1, "h") = "Çáì ÍÜ //"
''===================================

ii = i + 1
For g = 5 To LR
If Sh.Cells(g, "d").Value = ws.Range("g2").Value And Sh.Cells(g, "p").Value <> ws.Cells(ii, "h").Value Then
ii = ii + 1
ws.Cells(ii, "B") = Sh.Cells(g, 9)
ws.Cells(ii, "C") = Sh.Cells(g, 8)
ws.Cells(ii, "E") = "=SUMIFS(ÞíæÏ!C[6],ÞíæÏ!C[-1],R2C7,ÞíæÏ!C[11],RC[3])"
ws.Cells(ii, "F") = Sh.Cells(g, 12)
ws.Cells(ii, "h") = Sh.Cells(g, 16)
ws.Cells(ii, "i") = Sh.Cells(g, 19)
End If: Next
End Sub




21-02-2020 01:38 مساء
مشاهدة مشاركة منفردة [3]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 498
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 3836
الاعجاب : 75
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
جرب هذا الملف
الكود

Option Explicit
Sub Get_data()
Dim D As Worksheet, R As Worksheet
Dim Source_Ar(), Target_Ar()
Dim Source_RG As Range, Target_RG As Range, Cel As Range
Dim My_Num, Bol As Boolean, i%, x%: x = 5
Set D = Sheets("Data"): Set R = Sheets("Repport")
Set Source_RG = D.Range("A4").CurrentRegion
Set Target_RG = R.Range("B4").CurrentRegion

Target_RG.Offset(1).Clear
 Bol = IsError(Application.Match(R.Range("G2"), Source_RG.Columns(3), 0))
  If Bol Then MsgBox "The Data Not Found":  Exit Sub
      Source_Ar = Array("F", "E", "G", "H", "I", "J", "K", "L")
      Target_Ar = Array(2, 3, 4, 5, 6, 7, 8, 9)
 
   For Each Cel In Source_RG.Columns(3).Cells
        If Cel = R.Range("G2") Then
         For i = LBound(Source_Ar) To UBound(Source_Ar)
            R.Cells(x, Target_Ar(i)) = _
            D.Cells(Cel.Row, Source_Ar(i))
         Next
           x = x + 1
        End If
   Next Cel
  With R.Range("B5").Resize(x - 5, 8)
   .HorizontalAlignment = 1
   .VerticalAlignment = 2
   .InsertIndent 1: .Borders.LineStyle = 1
   .Font.Bold = True: .Font.Size = 14
  End With
End Sub

 
 
 
  Salim_data.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(39.447) KB


أثارت هذه المشاركة إعجاب: سعد عابد، YasserKhalil، ابو طيبه،



21-02-2020 01:48 مساء
مشاهدة مشاركة منفردة [4]
سعد عابد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 100
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
قوة السمعة : 114
الاعجاب : 3
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
اخى سليم
اشكرك شكرا جزيلا على المجهود المبذول فى الملف
===============
استدعاء البيانات بشرط واحد هو رقم الكود
هل ممكن اضافة شرط اخر وهو عدم تكرار اسم الحساب 
فمثلا على سبيل المثال
اذا كان الخزينة الرئيسية مكرره تاتى مره واحده




21-02-2020 02:31 مساء
مشاهدة مشاركة منفردة [5]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 498
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 3836
الاعجاب : 75
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
تم تعديل الماكرو (اضافة ماكرو ثاني ) للقيام بحذف كل الصف اذا كانت بياناته كلها مكررة
مثلا: A1=A2     B1=B2    C1=C2 ..... H1=H2
وهكذا

Option Explicit
Sub Get_data()
Dim D As Worksheet, R As Worksheet
Dim Source_Ar(), Target_Ar()
Dim Source_RG As Range, Target_RG As Range, Cel As Range
Dim Answer As Byte, Bol As Boolean, i%, x%: x = 5
Set D = Sheets("Data"): Set R = Sheets("Repport")
Set Source_RG = D.Range("A4").CurrentRegion
Set Target_RG = R.Range("B4").CurrentRegion

Target_RG.Offset(1).Clear
 Bol = IsError(Application.Match(R.Range("G2"), Source_RG.Columns(3), 0))
  If Bol Then MsgBox "The Data Not Found":  Exit Sub
      Source_Ar = Array("F", "E", "G", "H", "I", "J", "K", "L")
      Target_Ar = Array(2, 3, 4, 5, 6, 7, 8, 9)
 
   For Each Cel In Source_RG.Columns(3).Cells
        If Cel = R.Range("G2") Then
         For i = LBound(Source_Ar) To UBound(Source_Ar)
            R.Cells(x, Target_Ar(i)) = _
            D.Cells(Cel.Row, Source_Ar(i))
         Next
           x = x + 1
        End If
   Next Cel
  With R.Range("B5").Resize(x - 5, 8)
   .HorizontalAlignment = 1
   .VerticalAlignment = 2
   .InsertIndent 1: .Borders.LineStyle = 1
   .Font.Bold = True: .Font.Size = 14
  End With
  Answer = MsgBox("do you want to delete duplicate row" & Chr(10) & _
      "if there Existe", vbYesNo)
      If Answer = 6 Then del_rows
  
End Sub
'++++++++++++++++++++++++++++++++++++++++++
Sub del_rows()
If ActiveSheet.Name <> "Repport" Then Exit Sub
 Dim ro%, i%, My_rg As Range
 ro = Cells(Rows.Count, 2).End(3).Row
 Range("M5").Resize(ro - 4).Formula = _
 "=SUMPRODUCT(--(B5&C5&D5&E5&F5&G5&H5&I5=$B$5:B5&$C$5:C5&$D$5:D5&$E$5:E5&$F$5:F5&$G$5:G5&$H$5:H5&$I$5:I5))"
 For i = 5 To ro
   If Range("M" & i) > 1 Then
    If My_rg Is Nothing Then
     Set My_rg = Range("M" & i)
     Else
     Set My_rg = Union(Range("M" & i), My_rg)
    End If
   End If
 Next
   If Not My_rg Is Nothing Then My_rg.EntireRow.Delete
   Range("M:M").Clear
End Sub

 
 
 
  Salim_data_new.xlsm   تحميل xlsm مرات التحميل :(1)
الحجم :(41.66) KB


أثارت هذه المشاركة إعجاب: سعد عابد، YasserKhalil، ali mohamed ali، ابو طيبه،



07-03-2020 07:59 صباحا
مشاهدة مشاركة منفردة [6]
ابو طيبه
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 31-08-2019
رقم العضوية : 14499
المشاركات : 74
الجنس : ذكر
قوة السمعة : 82
الاعجاب : 25
 offline 
look/images/icons/i1.gif استدعاء بيانات بشروط
دائما مبدع استاذ سليم بارك الله بيك 






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
استدعاء بيانات الطلاب لفصل معين لمادة معينة (درس للمستوى المتقدم) YasserKhalil
19 2420 YasserKhalil
تعديل على كود الترحيل واستدعاء بيانات من شيت لاخر وعمل قائمة منسدله ابو طيبه
14 549 ابو طيبه
تعديل كواد النسخ الاحتياطيه وكواد الاستدعاء احمد 9598
6 145 Excelawy
فورم ترحيل بيانات واستدعاء وحفظ صور مجدى يونس
6 975 مجدى يونس
فورم بحث وزر استدعاء ملفات وزر حفظ واغلاق الاكسل مجدى يونس
11 994 مجدى يونس

الكلمات الدلالية
استدعاء ، بيانات ، بشروط ،


 







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

الساعة الآن 07:55 صباحا

أعلن هنا
أعلن هنا
أعلن هنا