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

ممكن تصحيح الكود


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

ممكن تصحيح الكود 

اخيرا لاقيت شرح كيفية عمل تقرير من شيت المشتريات والخزينة وطبقته

لكن فيه الكود خطاء مش عارف اوصله 

ممكن مساعدة من الاساتذة الكرام

برنامج المبيعات-5- 2020.xlsm

رابط هذا التعليق
شارك

الكود المطلوب

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

  • Like 2
رابط هذا التعليق
شارك

جزاك الله كل خير على الوقت والمجهود

لكن ليس المطلوب هذا 

المطلوب كشف حساب مورد 

التاريخ الصنف الكمية السعر القيمة ثم الصرف من الصندوق

لكن حضرتك مش استدعاء خزينة 

رابط هذا التعليق
شارك

الموضوع اخذ ما يكفي من الوقت ولا مجال لتخمين التنائج و لا لاضاعة الوقت  فيه بدون فائدة  ( لاني لم افهم ماذا تريددين بالضبط)

 كما ترين الجدولين  (مشتريات و خزينة مختلفين تصميماً من حبث عدد الأعمدة والمختويات)

     يرجي ادراج مثالاُ تطبيقياً ( بصفحة مستقلة) بالتنائج المتوقعة (يدوياً ) حتى اعرف اي طريق اسلك للاحابة

 

رابط هذا التعليق
شارك

تم معالجة الامر و عسى ان يكون المطلوب

الكود

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

  • Like 2
رابط هذا التعليق
شارك

الخزينة للمورد مش محتاج منها غير صف التاريخ والصرف فقط لاغير

اكيد ربنا يبارك ويكتر من امثال الاستاذ العظيم 

لكن فاضل تكة صغيرة هى احضار البيانات عمودين فقط هما التاريخ والصرف فقط 

رابط هذا التعليق
شارك

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

  • Like 4
رابط هذا التعليق
شارك

بصراحة ربنا يبارك فى حضرتك 

ويجعل علمك فى ميزان حسناتكم

لكن فاضل الحلو تكة 

هى ان تاريخ صرف الفلوس من الخزينة يكون تحت التاريخ العادى فى التقرير 

وبلاش المجموع الخاص بالفلوس 

حسابيا خطا

اسف لو بزعج حضرتك 

اخر شئ

لما حضرتك تجيب تاريخ صرف النقدية اسفل تاريخ الفاتورة 

ممكن يكون هناك فرز للبيانات على اساس التاريخ

رمضان كريم

 

رابط هذا التعليق
شارك

تم معالجة الامر

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك

اريد منكم تكمبة هذا التقرير من فضلكم 

عندما اكتب كلمة مورد تظهر اسماء الموردين 

وعندما اكتب كلمة عملاء تكتب  اسماء العملاء

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

وامثله عندما تكتب كلمة عميل تختار اسم من العملاء تظهر فواتير من صفحة المبيعات بالتفصيلى  والعمود التاريخ وعمود اضافة من الخزينة

وجزاكم الله كل خير ورمضان كريم

وعند الانتهاء يقوم بتصدير التقرير الى صغية BDF مع الحفظ فى مجلد معين له  

رابط هذا التعليق
شارك

والله كده حرام ... الموضوع كده اخذ اكبر من حجمه بمراحل

اجعل من وقت الأساتذة لمساعدة باقى الأعضاء ... يكفيك كل هذه الأكواد والمجهود الكبير ويجب غلق الموضوع حالاً

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

ما قدمه الأستاذ سليم من مجهودات جبارة فى مشاركتك يكفى لمساعدة أكثر من 10 أعضاء يحتاجون المساعدة أكثر من هذا

رابط هذا التعليق
شارك

الاستاذ المحترم مهند 

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

والله هذا العمل العظيم الى قدمه الاستاذ سليم  لنا 

ليس لى بمفردى ولكن هذا الشيت سوف يبقى فى المنتدى الف سنة 

فتكملته سيؤدى الى تمامه 

من فضلك الاستاذ سليم بعض من الوقت لتكمله عملك العظيم ليس من اجلى ولكن لكل المحاسبين سوف يذكرون عملك 

فأكمله وهذا ليس امرا بل رجاء .......................

من فضل الاستاذ مهند ممكن تساعد حضرتك بعمل فيديو تشرح فيه هذا العمل الرائع للاستاذ سليم  ولكن بعد اذن الاستاذ سليم طبعا 

لان لابد من انتساب الفضل لاهل الفضل

رابط هذا التعليق
شارك

  • أفضل إجابة

اخر ما يمكنني عمله

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

  • Like 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information