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

Mharee Accounting Albaig · سبتمبر 9

السلام عليكم

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

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

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

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

**محمد هشام.** · سبتمبر 10

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

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

تم تعديل سبتمبر 10 بواسطه محمد هشام.

Mharee Accounting Albaig · سبتمبر 10

السلام عليكم

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

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

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

مهاري

تم تعديل سبتمبر 10 بواسطه Mharee Accounting Albaig

**محمد هشام.** · سبتمبر 11

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

اولا سنقوم بتغيير طريقة تعبئة القوائم المنسدلة تفاديا للاخطاء وحدف الاكواد الموجودة على حدث 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

تم تعديل سبتمبر 11 بواسطه محمد هشام.

Mharee Accounting Albaig · سبتمبر 13

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

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

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

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

**محمد هشام.** · سبتمبر 13

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

بالتوفيق

Mharee Accounting Albaig · سبتمبر 14

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

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

مع التقدير

ممنون

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

تم تعديل سبتمبر 14 بواسطه Mharee Accounting Albaig

تسجيل الدخول

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

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

Mharee Accounting Albaig

محمد هشام.

Mharee Accounting Albaig

محمد هشام.

Mharee Accounting Albaig

محمد هشام.

Mharee Accounting Albaig

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information