اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تعديل فاتورة مبيعات


إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

السلام عليكم 

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

واي تعديلات ترونها مناسبة لتعم الفائدة للجميع 

الشكر الجزيل لادارة المنتدى 

 

فاتورة مبيعات مميزه.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته

17 ساعات مضت, Mharee Accounting Albaig said:

القائمة المنسدلة بان تقرا الى المادة 117 اي توسيع المدى اضافة تعديل وضعها الى ألأكواد بدل المعادلات 

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

 ضع الكود التالي في Module

Sub Add_listeDéroulante()

    Dim lr As Long, arr() As String
    Dim cnt As New Collection
    Dim r As Range, rng As Range, i As Long
    Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1")
    Dim dest As Worksheet: Set dest = ThisWorkbook.Sheets("Sheet2")
    lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row

    On Error Resume Next
    For Each r In dest.Range("B4:B" & lr)
        If r.Value <> "" Then
            cnt.Add r.Value, CStr(r.Value)
        End If
    Next r
    On Error GoTo 0
    If cnt.Count = 0 Then: Exit Sub
    ReDim arr(1 To cnt.Count)
    For i = 1 To cnt.Count
        arr(i) = cnt(i)
    Next i
    Set rng = WS.Range("B15:B24")
    With rng.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
         xlBetween, Formula1:=Join(arr, ",")
        .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True
    End With
End Sub

وفي حدث Sheet1 ضع الكود التالي سيتم جلب السعر  عند التغيير أو الإضافة في عمود البيان  وحساب القيمة عند الإدخال في عمود الكمية 

Private Sub Worksheet_Activate()
Add_listeDéroulante
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet, data As Worksheet, result As Double
    Dim OnRng As Range, Search As Range, tmp As Range
    Dim lastRow As Long, i As Long, ColSum As Range
    
    On Error GoTo ErrorHandler
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set WS = ThisWorkbook.Sheets("Sheet1")
    Set data = ThisWorkbook.Sheets("Sheet2")

    If Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then
        lastRow = data.Cells(data.Rows.Count, 2).End(xlUp).Row
        Set OnRng = data.Range("B4:B" & lastRow)

        For Each tmp In Intersect(Target, WS.Range("B15:B24"))
            If Not IsEmpty(tmp.Value) Then
                Set Search = OnRng.Find(What:=tmp.Value, LookIn:=xlValues, LookAt:=xlWhole)
                WS.Cells(tmp.Row, 4).Value = IIf(Not Search Is Nothing, Search.Offset(0, 1).Value, "")
            Else
                WS.Cells(tmp.Row, 4).Value = ""
            End If
        Next tmp
    End If
    
    If Not Intersect(Target, WS.Range("C15:D24")) Is Nothing Or _
       Not Intersect(Target, WS.Range("B15:B24")) Is Nothing Then
        For i = 15 To 24
            If IsNumeric(WS.Cells(i, 3).Value) And IsNumeric(WS.Cells(i, 4).Value) Then
                result = WS.Cells(i, 4).Value * WS.Cells(i, 3).Value
                WS.Cells(i, 5).Value = IIf(result <> 0, result, "")
            Else
                WS.Cells(i, 5).Value = ""
            End If
        Next i
        Set ColSum = WS.Range("E15:E24")
        If Application.WorksheetFunction.CountA(ColSum) = 0 Then
            WS.Range("E25").Value = ""
        Else
            WS.Range("E25").Value = Application.WorksheetFunction.Sum(ColSum)
        End If
    End If

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Erreur: " & Err.Description
End Sub

وأخيرا في حدث ThisWorkbook ضع السطور التالية لتحديث القوائم عند فتح الملف وحدفها عند الإغلاق تفاديا للأخطاء 

Private Sub Workbook_Open()
Add_listeDéroulante
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Sheets("Sheet1")
    WS.Range("B15:B24").Validation.Delete
End Sub

بالتوفيق...

 

فاتورة مبيعات مميزه 1.xlsm

تم تعديل بواسطه محمد هشام.
  • Like 1
رابط هذا التعليق
شارك

السلام عليكم 

يعجز اللسان عن الشكر والتقدير حقيقة حليت لنا مشكلة كبيرة الله يجعلها في ميزان حسناتك وكافة اعضاء الكروب الكرام 

بس حبيت استفسر حول زر الحفز حيث انه يعطي لي رقم وتبقى المعلومات كما هي هل بالأمكان ترحيل او عندة انهاء العمل طلب فاتوة جديد تظهر لي لي الفورمة خالية من الارقام 

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

مهاري 

 

تم تعديل بواسطه Mharee Accounting Albaig
رابط هذا التعليق
شارك

  • أفضل إجابة

نعم اخي يمكننا تنفيد دالك بعد تعديل بعض الاجراءات على الملف وتعديل الاكواد بما يتناسب مع طلبك 

اولا سنقوم بتغيير طريقة تعبئة القوائم المنسدلة تفاديا للاخطاء  وحدف الاكواد الموجودة على حدث ThisWorkbook 

Sub Add_listeDéroulante()
    Dim OnRng As Range, Data As Range
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    Dim f As Worksheet: Set f = Sheets("Sheet2")
    
   Set OnRng = WS.Range("B15:B24")
    Set Data = f.Range(f.Range("P4"), f.Range("P" & f.Rows.Count).End(xlUp))
        With OnRng.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="='" & f.Name & "'!" & Data.Address
        .InCellDropdown = True
        .ShowError = True
    End With
    
End Sub

في حدث Sheet2 

Private Sub Worksheet_Change(ByVal Target As Range)
    
If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False

        Dim tmp As Object
        Set tmp = CreateObject("Scripting.Dictionary")
        
        Dim n As Range
        For Each n In Range("B4", [B65000].End(xlUp))
            If n.Value <> "" Then tmp(n.Value) = ""
        Next n
        
        With Range("P4:P65000")
            .ClearContents
            .Resize(tmp.Count) = Application.Transpose(tmp.Keys)
        End With
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

كود حفظ الفاتورة PDF داخل مجلد في نفس مسار الملف 

Sub Print_the_invoice()
    Dim s As Range, cell As Range
    Dim i As Long, r As Long, arr As Variant
    Dim Num_Inv As String, Client As String
    Dim n As String, Cnt As String, xDate As String
    Dim dossier As String, xPath As String
    
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    Set ligne = WS.[B15:E15]
    xDate = WS.[E13].Value
    Client = WS.[B11].Value
    Num_Inv = WS.[E11].Value

    arr = Array(Client, Num_Inv, xDate)
    For i = 0 To UBound(arr)
        If IsEmpty(arr(i)) Or arr(i) = "" Then
            n = "يرجى ملء بيانات " & Choose(i + 1, "إسم العميل", "رقم الفاتورة", "تاريخ الفاتورة")
            MsgBox n, vbExclamation, "تنبيه"
            Exit Sub
        End If
        
        If i = 1 And Not IsNumeric(arr(i)) Then
            MsgBox "يرجى التحقق من رقم الفاتورة", vbExclamation, "تنبيه"
            Exit Sub
        End If
    Next i
    
    For Each cell In ligne
        If IsEmpty(cell.Value) Then MsgBox "المرجوا التحقق من بيانات الفاتورة", vbExclamation: Exit Sub
    Next cell
    
    Cnt = WS.[D11].Value & " : " & Num_Inv & "     " & _
          WS.[A11].Value & " :  " & Client & "  " & vbCrLf & vbCrLf & _
          WS.[A25].Value & " :  " & Format(WS.[E25].Value, "##,0") & vbCrLf & vbCrLf

    If MsgBox(Cnt & vbCrLf & "هل تريد طباعة الفاتورة؟", vbYesNo + vbQuestion, "تأكيد طباعة الفاتورة") = vbNo Then
        Exit Sub
    End If

    Application.ScreenUpdating = False
    dossier = ThisWorkbook.Path & "\Invoices"
    If Dir(dossier, vbDirectory) = "" Then
        MkDir dossier
    End If
    xPath = dossier & "\" & Client & ".pdf"
    
    With WS
        Rows(15 & ":" & 24).EntireRow.Hidden = False
        For i = 15 To 24
            If Cells(i, "B") = "" Then Rows(i).Hidden = True
        Next i
        
        .PageSetup.PrintArea = "A1:E35"
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=xPath
        Rows(15 & ":" & 24).EntireRow.Hidden = False
    End With
    
    r = CLng(Num_Inv)
    r = r + 1
    WS.[E11].Value = Format(r, "00000")

    If MsgBox("هل تريد تفريغ بيانات الفاتورة؟", vbYesNo + vbQuestion, "تأكيد تفريغ البيانات") = vbYes Then
        Union(WS.Range("B11:B13"), WS.Range("E13"), WS.Range("B15:C24")).ClearContents
    End If
    
    Application.ScreenUpdating = True
End Sub

فاتورة جديدة 

Sub New_invoice()
    Dim n As Variant, t As Long, rng As Range
    Dim WS As Worksheet: Set WS = Sheets("Sheet1")
    
    Set rng = WS.[E15:E24]
    n = WS.[E11].Value
    
    
    If Application.WorksheetFunction.CountA(rng) = 0 Then: Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    If MsgBox("فاتــورة جديدة؟", vbYesNo + vbQuestion, "تأكيد تفريغ البيانات") = vbYes Then
        Union(WS.Range("B11:B13"), WS.Range("E13"), WS.Range("B15:E24"), WS.Range("E25")).ClearContents
        
        If IsNumeric(n) Then
                 t = CLng(n)
                 t = t + 1
                 WS.[E11].Value = Format(t, "00000")
             End If
         End If
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

فاتورة مبيعات مميزه2.xlsm

تم تعديل بواسطه محمد هشام.
  • Like 1
رابط هذا التعليق
شارك

ششششششششششششششششششكرا جزيلا ربي يحفظكم ويبارك بيكم  . عفوا اني اضفت محرك بحث على اسم المادة في الفاتورة بس يحتاج تعديل بسيط لكي يكون البحث اكثر تطور واسهل فرز . وانشاء الله الفائدة تعم للجميع وهذا بفضل منتدانا العزيز 

الف الف شكر ورحم الله والديكم 

فاتورة مبيعات مميزه 3.rar

تم تعديل بواسطه Mharee Accounting Albaig
اضافة محرك بحث وفكرة جديدة
رابط هذا التعليق
شارك

اخي طلبك الاخير غير واضح بالنسبة لي حاول فتح موضوع جديد مع شرح النتائج المتوقعة بشكل افضل وان شاء الله سوف نحاول مساعدتك 

بالتوفيق 

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

استاذي الغالي  في الشيت الأول في الفاتورة عامود ( B15 )ركبت محرك بحث عند الضرب على الخلية دبل كلك حيث تخرج نافذة بحث مرتبطة بالشيت الثاني وهو اسماء المواد . ما احتاجة هو انه تقرا نفذة البحث من المواد الموجود في الشيت الثاني 

اتمنى ان اكون وضحت المضمون 

مع التقدير 

ممنون 

فاتورة مبيعات مميزه 3.xlsm

تم تعديل بواسطه Mharee Accounting Albaig
رابط هذا التعليق
شارك

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

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

Important Information