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

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


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





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

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



17-02-2020 04:43 مساء
سعد عابد
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 135
الدولة : مصر
الجنس : ذكر
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 220
عدد الإجابات: 3
 offline 

السلام عليكم 
استدعاء قيد محاسبى الشرط الاساسى رقم القيد
وقد كتبت الكود ويعمل بكفاءه
ولكن 
اريد اضافة شروط اخرى 
اذا كان اسم الحساب متشابه سواء مدين او دائن لا يتكرر ويجمع المبلغ 
يوجد ثلاث امثلة للنتائج المستهدفه فى الملف
اشكركم
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  استدعاء قيد.xlsb   تحميل xlsb مرات التحميل :(5)
الحجم :(26.289) KB


20-02-2020 10:04 مساء
مشاهدة مشاركة منفردة [1]
سعد عابد
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 135
الدولة : مصر
الجنس : ذكر
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 220
عدد الإجابات: 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 مرات التحميل :(1)
الحجم :(21.056) KB


21-02-2020 11:33 صباحا
مشاهدة مشاركة منفردة [2]
سعد عابد
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 135
الدولة : مصر
الجنس : ذكر
يتابعهم : 6
يتابعونه : 1
قوة السمعة : 220
عدد الإجابات: 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
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 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 مرات التحميل :(4)
الحجم :(39.447) KB


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

21-02-2020 02:31 مساء
مشاهدة مشاركة منفردة [5]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 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 مرات التحميل :(3)
الحجم :(41.66) KB


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




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


 










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

الساعة الآن 06:55 مساء