Mharee Accounting Albaig قام بنشر سبتمبر 9 مشاركة قام بنشر سبتمبر 9 السلام عليكم عفوا من رخصة الأخوان عندي هذه الفاتور محتاج فيها تعديل القائمة المنسدلة بان تقرا الى المادة 117 اي توسيع المدى اضافة تعديل وضعها الى ألأكواد بدل المعادلات واي تعديلات ترونها مناسبة لتعم الفائدة للجميع الشكر الجزيل لادارة المنتدى فاتورة مبيعات مميزه.xlsm رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 10 مشاركة قام بنشر سبتمبر 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 بواسطه محمد هشام. 1 رابط هذا التعليق شارك More sharing options...
Mharee Accounting Albaig قام بنشر سبتمبر 10 الكاتب مشاركة قام بنشر سبتمبر 10 (معدل) السلام عليكم يعجز اللسان عن الشكر والتقدير حقيقة حليت لنا مشكلة كبيرة الله يجعلها في ميزان حسناتك وكافة اعضاء الكروب الكرام بس حبيت استفسر حول زر الحفز حيث انه يعطي لي رقم وتبقى المعلومات كما هي هل بالأمكان ترحيل او عندة انهاء العمل طلب فاتوة جديد تظهر لي لي الفورمة خالية من الارقام اني اعرف ثقلت بس اكرر ممنونة جدا مهاري تم تعديل سبتمبر 10 بواسطه Mharee Accounting Albaig رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر سبتمبر 11 أفضل إجابة مشاركة قام بنشر سبتمبر 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 بواسطه محمد هشام. 1 رابط هذا التعليق شارك More sharing options...
Mharee Accounting Albaig قام بنشر سبتمبر 13 الكاتب مشاركة قام بنشر سبتمبر 13 (معدل) ششششششششششششششششششكرا جزيلا ربي يحفظكم ويبارك بيكم . عفوا اني اضفت محرك بحث على اسم المادة في الفاتورة بس يحتاج تعديل بسيط لكي يكون البحث اكثر تطور واسهل فرز . وانشاء الله الفائدة تعم للجميع وهذا بفضل منتدانا العزيز الف الف شكر ورحم الله والديكم فاتورة مبيعات مميزه 3.rar تم تعديل سبتمبر 13 بواسطه Mharee Accounting Albaig اضافة محرك بحث وفكرة جديدة رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر سبتمبر 13 مشاركة قام بنشر سبتمبر 13 اخي طلبك الاخير غير واضح بالنسبة لي حاول فتح موضوع جديد مع شرح النتائج المتوقعة بشكل افضل وان شاء الله سوف نحاول مساعدتك بالتوفيق رابط هذا التعليق شارك More sharing options...
Mharee Accounting Albaig قام بنشر سبتمبر 14 الكاتب مشاركة قام بنشر سبتمبر 14 (معدل) استاذي الغالي في الشيت الأول في الفاتورة عامود ( B15 )ركبت محرك بحث عند الضرب على الخلية دبل كلك حيث تخرج نافذة بحث مرتبطة بالشيت الثاني وهو اسماء المواد . ما احتاجة هو انه تقرا نفذة البحث من المواد الموجود في الشيت الثاني اتمنى ان اكون وضحت المضمون مع التقدير ممنون فاتورة مبيعات مميزه 3.xlsm تم تعديل سبتمبر 14 بواسطه Mharee Accounting Albaig رابط هذا التعليق شارك More sharing options...
الردود الموصى بها