marwa41 قام بنشر مايو 2, 2020 قام بنشر مايو 2, 2020 ممكن تصحيح الكود اخيرا لاقيت شرح كيفية عمل تقرير من شيت المشتريات والخزينة وطبقته لكن فيه الكود خطاء مش عارف اوصله ممكن مساعدة من الاساتذة الكرام برنامج المبيعات-5- 2020.xlsm
marwa41 قام بنشر مايو 2, 2020 الكاتب قام بنشر مايو 2, 2020 عدلت االى على الخطوط الحمراء ظهرت الرسالة دى سبب ظهورها برنامج المبيعات-5- 2020.xlsm
سليم حاصبيا قام بنشر مايو 3, 2020 قام بنشر مايو 3, 2020 الكود المطلوب Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub Sub Tranfer_data() Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("التاريخ", "العميل", "البيان", _ "الوارد", "الصرف", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("a8").CurrentRegion.Rows.Count - 1).ClearContents i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(start_Ro, 1).Resize(, 6).Value = arr i = 5 start_Ro = start_Ro + 1 '++++++++++++++++++++++++++++++++++++++ Do Until K.Range("C" & i) = vbNullString x = K.Range("D" & i) = mot: y = K.Range("C" & i) >= Start_date z = K.Range("C" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 6).Value = _ K.Cells(i, 3).Resize(, 6).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop '+++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data.xlsm 2
marwa41 قام بنشر مايو 3, 2020 الكاتب قام بنشر مايو 3, 2020 جزاك الله كل خير على الوقت والمجهود لكن ليس المطلوب هذا المطلوب كشف حساب مورد التاريخ الصنف الكمية السعر القيمة ثم الصرف من الصندوق لكن حضرتك مش استدعاء خزينة
سليم حاصبيا قام بنشر مايو 3, 2020 قام بنشر مايو 3, 2020 الموضوع اخذ ما يكفي من الوقت ولا مجال لتخمين التنائج و لا لاضاعة الوقت فيه بدون فائدة ( لاني لم افهم ماذا تريددين بالضبط) كما ترين الجدولين (مشتريات و خزينة مختلفين تصميماً من حبث عدد الأعمدة والمختويات) يرجي ادراج مثالاُ تطبيقياً ( بصفحة مستقلة) بالتنائج المتوقعة (يدوياً ) حتى اعرف اي طريق اسلك للاحابة
marwa41 قام بنشر مايو 3, 2020 الكاتب قام بنشر مايو 3, 2020 شكرا ليس هو المطلوب SAL_My_data.xlsm ليس اضاعة وقت لكن فعلا ليس هـــــــــــــــــــــو المطلوب المطلوب فى صفحى الموجود كشف حساب عادى
سليم حاصبيا قام بنشر مايو 3, 2020 قام بنشر مايو 3, 2020 تم معالجة الامر و عسى ان يكون المطلوب الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim arr() Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") arr = Array("الصرف", "الوارد", "الرصيد") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop R.Cells(8, "K").Resize(, 3).Value = arr: Erase arr i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsNumeric(K.Cells(Actrow, "F")), K.Cells(Actrow, "F"), 0) R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), 0) R.Cells(m, "M") = _ R.Cells(m, "L") - R.Cells(m, "k") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "k").Resize(, 3).Formula = _ "=SUM(K9:K" & ALLROW - 1 & ")" R.Cells(ALLROW, "k").Resize(, 3).Value = _ R.Cells(ALLROW, "k").Resize(, 3).Value '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق للمرة الثانية SAL_My_data_2.xlsm 2
marwa41 قام بنشر مايو 3, 2020 الكاتب قام بنشر مايو 3, 2020 الخزينة للمورد مش محتاج منها غير صف التاريخ والصرف فقط لاغير اكيد ربنا يبارك ويكتر من امثال الاستاذ العظيم لكن فاضل تكة صغيرة هى احضار البيانات عمودين فقط هما التاريخ والصرف فقط
سليم حاصبيا قام بنشر مايو 3, 2020 قام بنشر مايو 3, 2020 54 دقائق مضت, marwa41 said: لكن فاضل تكة صغيرة هى احضار البيانات عمودين فقط هما التاريخ والصرف فقط تم التعديل Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "k") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "k").NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Cells(m, "L") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ R.Cells(ALLROW, "K") = "المجموع" R.Cells(ALLROW, "L") = _ Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق SAL_My_data_3.xlsm 4
abouelhassan قام بنشر مايو 3, 2020 قام بنشر مايو 3, 2020 استاذنا سليم حاصبيا والله مشكور جدااا بارك الله فيك احترام من القلب 1
marwa41 قام بنشر مايو 3, 2020 الكاتب قام بنشر مايو 3, 2020 بصراحة ربنا يبارك فى حضرتك ويجعل علمك فى ميزان حسناتكم لكن فاضل الحلو تكة هى ان تاريخ صرف الفلوس من الخزينة يكون تحت التاريخ العادى فى التقرير وبلاش المجموع الخاص بالفلوس حسابيا خطا اسف لو بزعج حضرتك اخر شئ لما حضرتك تجيب تاريخ صرف النقدية اسفل تاريخ الفاتورة ممكن يكون هناك فرز للبيانات على اساس التاريخ رمضان كريم
سليم حاصبيا قام بنشر مايو 4, 2020 قام بنشر مايو 4, 2020 تم معالجة الامر Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo"): Set A = Sheets("Achat") Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "C") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "K") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 '++++++++++++++++++++++++++++++++++++++++++ ' R.Cells(ALLROW, "K") = "المجموع" ' R.Cells(ALLROW, "L") = _ ' Evaluate("=SUM(L9:L" & ALLROW - 1 & ")") '++++++++++++++++++++++++++++++++++++++++++ End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With R.Range("A8").CurrentRegion.Columns(3).NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Range("A8").CurrentRegion.Sort key1:=R.Cells(1, 3), Header:=1 End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف الرابع مرفق SAL_My_data_4.xlsm 1 1
marwa41 قام بنشر مايو 4, 2020 الكاتب قام بنشر مايو 4, 2020 اريد منكم تكمبة هذا التقرير من فضلكم عندما اكتب كلمة مورد تظهر اسماء الموردين وعندما اكتب كلمة عملاء تكتب اسماء العملاء بالتالى التقرير عند كتابة المورد واختار اسم مورد تظهر الفواتير من صفحة المشتريات بالتفصيلى والعمود التاريخ وعمود الصرف من الخزينة وامثله عندما تكتب كلمة عميل تختار اسم من العملاء تظهر فواتير من صفحة المبيعات بالتفصيلى والعمود التاريخ وعمود اضافة من الخزينة وجزاكم الله كل خير ورمضان كريم وعند الانتهاء يقوم بتصدير التقرير الى صغية BDF مع الحفظ فى مجلد معين له
مهند محسن قام بنشر مايو 4, 2020 قام بنشر مايو 4, 2020 والله كده حرام ... الموضوع كده اخذ اكبر من حجمه بمراحل اجعل من وقت الأساتذة لمساعدة باقى الأعضاء ... يكفيك كل هذه الأكواد والمجهود الكبير ويجب غلق الموضوع حالاً حقاً استاذ سليم انت رجل صبور جداً وتسعى دائما كالعادة الى مساعدة الأخرين بارك الله فيك ووسع الله فى رزقك وأكرمك الله دنيا واخره ما قدمه الأستاذ سليم من مجهودات جبارة فى مشاركتك يكفى لمساعدة أكثر من 10 أعضاء يحتاجون المساعدة أكثر من هذا
marwa41 قام بنشر مايو 5, 2020 الكاتب قام بنشر مايو 5, 2020 الاستاذ المحترم مهند فعلا الاستاذ سليم فعلا قدم من العلم ومن الوقت والمجهود ما يستحق عليه الشكر والله هذا العمل العظيم الى قدمه الاستاذ سليم لنا ليس لى بمفردى ولكن هذا الشيت سوف يبقى فى المنتدى الف سنة فتكملته سيؤدى الى تمامه من فضلك الاستاذ سليم بعض من الوقت لتكمله عملك العظيم ليس من اجلى ولكن لكل المحاسبين سوف يذكرون عملك فأكمله وهذا ليس امرا بل رجاء ....................... من فضل الاستاذ مهند ممكن تساعد حضرتك بعمل فيديو تشرح فيه هذا العمل الرائع للاستاذ سليم ولكن بعد اذن الاستاذ سليم طبعا لان لابد من انتساب الفضل لاهل الفضل
أفضل إجابة سليم حاصبيا قام بنشر مايو 5, 2020 أفضل إجابة قام بنشر مايو 5, 2020 اخر ما يمكنني عمله Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$B$4" And Target.Count = 1 Then Tranfer_data End If Application.EnableEvents = True End Sub '////////////////////////////////////////////// Sub Tranfer_data() Application.EnableEvents = False Dim R As Worksheet, A As Worksheet, K As Worksheet Dim start_Ro%, i%, m% Dim Start_date As Date, End_date As Date, mot$ Dim x As Boolean, y As Boolean, z As Boolean, t As Byte Dim KRg, Fixrow%, Actrow%, Find_rg As Range, Spec_Rg As Range Dim SF#, SG#, ALLROW% Set R = Sheets("repo") Select Case R.Range("F2") Case "الموردين": Set A = Sheets("Achat") Case "العملاء": Set A = Sheets("Mabi3at") Case Else: GoTo End_Me End Select Set K = Sheets("Kazina") K.Range("B3").CurrentRegion.Interior.ColorIndex = xlNone Start_date = R.Range("B2"): End_date = R.Range("B3"): mot = R.Range("B4") If R.Range("A8").CurrentRegion.Rows.Count > 1 Then _ R.Range("A8").CurrentRegion.Offset(1). _ Resize(R.Range("A8").CurrentRegion.Rows.Count - 1).Clear i = 5: start_Ro = 9 Do Until A.Range("B" & i) = vbNullString x = A.Range("B" & i) = mot: y = A.Range("D" & i) >= Start_date z = A.Range("D" & i) <= End_date t = Abs(x * y * z) If t Then R.Cells(start_Ro, 1).Resize(, 10).Value = _ A.Cells(i, 2).Resize(, 10).Value start_Ro = start_Ro + 1 End If i = i + 1 Loop i = 5 Set Find_rg = K.Range("B3").CurrentRegion.Columns(3) Set Spec_Rg = Find_rg.Find(mot, lookat:=1) If Not Spec_Rg Is Nothing Then Fixrow = Spec_Rg.Row: Actrow = Fixrow i = 9: m = 9 Do '================================== y = K.Cells(Actrow, "C") >= Start_date z = K.Cells(Actrow, "C") <= End_date t = Abs(y * z) If t Then R.Cells(m, "C") = _ IIf(IsDate(K.Cells(Actrow, "C")), K.Cells(Actrow, "C"), "") R.Cells(m, "K") = _ IIf(IsNumeric(K.Cells(Actrow, "G")), K.Cells(Actrow, "G"), "") K.Cells(Actrow, 2).Resize(, 7).Interior.ColorIndex = 40 m = m + 1 End If Set Spec_Rg = Find_rg.FindNext(Spec_Rg) Actrow = Spec_Rg.Row i = i + 1 Loop Until Fixrow = Actrow ALLROW = R.Range("A8").CurrentRegion.Rows.Count + 8 End If Set Spec_Rg = R.Range("A8").CurrentRegion If Spec_Rg.Rows.Count = 1 Then GoTo End_Me Set Spec_Rg = Spec_Rg.Offset(1).Resize(Spec_Rg.Rows.Count - 1) Set Spec_Rg = Spec_Rg.SpecialCells(2) With Spec_Rg .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 40 End With R.Range("A8").CurrentRegion.Columns(3).NumberFormat = "[$-ar-LB] dddd d mmmm yyyy" R.Range("A8").CurrentRegion.Sort key1:=R.Cells(1, 3), Header:=1 End_Me: Application.EnableEvents = True ' '++++++++++++++++++++++++++++++++++++++ End Sub الملف للمرة الخامسة و الأخيرة SAL_My_data_5.xlsm 1
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.