mohamadhaje

السلام عليكم ورحمة الله وبركاته ارجو المساعزد في تصحيح الكود التالي ولكم جزيل الشكر Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ErrorHandler ' معالجة الأخطاء Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("فاتورة مبيعات ") ' عدّل الاسم إذا كان مختلفًا Dim LastRow As Long LastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row ' تحديث المعادلة فقط عند تعديل العمودين F أو E If Not Intersect(Target, ws.Columns("F:E")) Is Nothing Then Application.EnableEvents = False ' تعطيل الأحداث لمنع الحلقات ws.Range("G5:G" & LastRow).Formula = "=IF(AND(F5<>"""", E5<>""""), F5*E5, """")" Application.EnableEvents = True ' إعادة تمكين الأحداث End If Exit Sub ErrorHandler: Application.EnableEvents = True ' تأكد من إعادة تمكين الأحداث في حالة حدوث خطأ MsgBox "حدث خطأ: " & Err.Description, vbExclamation End Sub طط.xlsm

ارجو مساعدتي بانشاء زر ترحيل وانشاء فاتورة جديدة وحساب تلقائي للقيم الاجمالية لايتاثر بالترحيل ولم جزيل الشكر بقيت عندي مشكلة حساب الاجمالي في الفاتورة ولايتأثر بالترحيل والكود الذي استخدمه هو Sub ترحيل_البيانات() Dim wsInvoice As Worksheet Dim wsSales As Worksheet Dim nextRow As Long Dim i As Integer ' تحديد الأوراق Set wsInvoice = ThisWorkbook.Sheets("فاتورة مبيعات") Set wsSales = ThisWorkbook.Sheets("مبيعات") ' إيجاد الصف التالي في ورقة "مبيعات" nextRow = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).row + 1 ' رقم الفاتورة التلقائي If IsEmpty(wsInvoice.Range("B2").Value) Then wsInvoice.Range("B2").Value = Application.WorksheetFunction.Max(wsSales.Columns("A")) + 1 End If ' حساب الإجمالي في الفاتورة (E8:E23) For i = 8 To 23 If wsInvoice.Cells(i, "C").Value <> "" And wsInvoice.Cells(i, "D").Value <> "" Then wsInvoice.Cells(i, "E").Value = wsInvoice.Cells(i, "C").Value * wsInvoice.Cells(i, "D").Value Else wsInvoice.Cells(i, "E").Value = "" ' إذا لم تكن الكمية أو السعر مدخلة، تكون الخلية فارغة End If Next i ' ترحيل البيانات العامة wsSales.Cells(nextRow, "A").Value = wsInvoice.Range("B2").Value ' رقم الفاتورة wsSales.Cells(nextRow, "B").Value = Date ' تاريخ اليوم wsSales.Cells(nextRow, "K").Value = wsInvoice.Range("B4").Value ' الصندوق wsSales.Cells(nextRow, "M").Value = wsInvoice.Range("F4").Value ' طريقة الدفع wsSales.Cells(nextRow, "H").Value = wsInvoice.Range("F5").Value ' المدفوع wsSales.Cells(nextRow, "L").Value = wsInvoice.Range("D4").Value ' المستودع wsSales.Cells(nextRow, "C").Value = wsInvoice.Range("D2").Value ' اسم العميل ' ترحيل التفاصيل (نوع المادة، الكمية، السعر، الإجمالي، البيان) For i = 8 To 30 If wsInvoice.Cells(i, "B").Value <> "" Then ' التحقق من وجود بيانات wsSales.Cells(nextRow, "D").Value = wsInvoice.Cells(i, "B").Value ' نوع المادة wsSales.Cells(nextRow, "E").Value = wsInvoice.Cells(i, "C").Value ' الكمية wsSales.Cells(nextRow, "F").Value = wsInvoice.Cells(i, "D").Value ' السعر wsSales.Cells(nextRow, "G").Value = wsInvoice.Cells(i, "E").Value ' الإجمالي wsSales.Cells(nextRow, "J").Value = wsInvoice.Cells(i, "F").Value ' البيان nextRow = nextRow + 1 End If Next i يرجى التصحيح ولكم جزيل الشكر ' إعادة تعيين رقم الفاتورة للمرة القادمة wsInvoice.Range("B2").Value = Application.WorksheetFunction.Max(wsSales.Columns("A")) + 1 ' مسح البيانات من ورقة "فاتورة مبيعات" wsInvoice.Range("B4").ClearContents ' الصندوق wsInvoice.Range("F4").ClearContents ' طريقة الدفع wsInvoice.Range("F5").ClearContents ' المدفوع wsInvoice.Range("D4").ClearContents ' المستودع wsInvoice.Range("D2").ClearContents ' اسم العميل wsInvoice.Range("B8:F30").ClearContents ' التفاصيل: نوع المادة، الكمية، السعر، الإجمالي، البيان MsgBox "تم ترحيل البيانات بنجاح وتم تفريغ الفاتورة!", vbInformation End Sub حساب.xlsm

ارجو مساعدتي بانشاء زر ترحيل وانشاء فاتورة جديدة وحساب تلقائي للقيم الاجمالية لايتاثر بالترحيل ولم جزيل الشكر بقيت عندي مشكلة حساب الاجمالي في الفاتورة ولايتأثر بالترحيل والكود الذي استخدمه هو Sub ترحيل_البيانات() Dim wsInvoice As Worksheet Dim wsSales As Worksheet Dim nextRow As Long Dim i As Integer ' تحديد الأوراق Set wsInvoice = ThisWorkbook.Sheets("فاتورة مبيعات") Set wsSales = ThisWorkbook.Sheets("مبيعات") ' إيجاد الصف التالي في ورقة "مبيعات" nextRow = wsSales.Cells(wsSales.Rows.Count, "A").End(xlUp).row + 1 ' رقم الفاتورة التلقائي If IsEmpty(wsInvoice.Range("B2").Value) Then wsInvoice.Range("B2").Value = Application.WorksheetFunction.Max(wsSales.Columns("A")) + 1 End If ' حساب الإجمالي في الفاتورة (E8:E23) For i = 8 To 23 If wsInvoice.Cells(i, "C").Value <> "" And wsInvoice.Cells(i, "D").Value <> "" Then wsInvoice.Cells(i, "E").Value = wsInvoice.Cells(i, "C").Value * wsInvoice.Cells(i, "D").Value Else wsInvoice.Cells(i, "E").Value = "" ' إذا لم تكن الكمية أو السعر مدخلة، تكون الخلية فارغة End If Next i ' ترحيل البيانات العامة wsSales.Cells(nextRow, "A").Value = wsInvoice.Range("B2").Value ' رقم الفاتورة wsSales.Cells(nextRow, "B").Value = Date ' تاريخ اليوم wsSales.Cells(nextRow, "K").Value = wsInvoice.Range("B4").Value ' الصندوق wsSales.Cells(nextRow, "M").Value = wsInvoice.Range("F4").Value ' طريقة الدفع wsSales.Cells(nextRow, "H").Value = wsInvoice.Range("F5").Value ' المدفوع wsSales.Cells(nextRow, "L").Value = wsInvoice.Range("D4").Value ' المستودع wsSales.Cells(nextRow, "C").Value = wsInvoice.Range("D2").Value ' اسم العميل ' ترحيل التفاصيل (نوع المادة، الكمية، السعر، الإجمالي، البيان) For i = 8 To 30 If wsInvoice.Cells(i, "B").Value <> "" Then ' التحقق من وجود بيانات wsSales.Cells(nextRow, "D").Value = wsInvoice.Cells(i, "B").Value ' نوع المادة wsSales.Cells(nextRow, "E").Value = wsInvoice.Cells(i, "C").Value ' الكمية wsSales.Cells(nextRow, "F").Value = wsInvoice.Cells(i, "D").Value ' السعر wsSales.Cells(nextRow, "G").Value = wsInvoice.Cells(i, "E").Value ' الإجمالي wsSales.Cells(nextRow, "J").Value = wsInvoice.Cells(i, "F").Value ' البيان nextRow = nextRow + 1 End If Next i يرجى التصحيح ولكم جزيل الشكر ' إعادة تعيين رقم الفاتورة للمرة القادمة wsInvoice.Range("B2").Value = Application.WorksheetFunction.Max(wsSales.Columns("A")) + 1 ' مسح البيانات من ورقة "فاتورة مبيعات" wsInvoice.Range("B4").ClearContents ' الصندوق wsInvoice.Range("F4").ClearContents ' طريقة الدفع wsInvoice.Range("F5").ClearContents ' المدفوع wsInvoice.Range("D4").ClearContents ' المستودع wsInvoice.Range("D2").ClearContents ' اسم العميل wsInvoice.Range("B8:F30").ClearContents ' التفاصيل: نوع المادة، الكمية، السعر، الإجمالي، البيان MsgBox "تم ترحيل البيانات بنجاح وتم تفريغ الفاتورة!", vbInformation End Sub حساب.xlsm

ارجو مساعدتي بانشاء زر ترحيل وانشاء فاتورة جديدة وحساب تلقائي للقيم الاجمالية لايتاثر بالترحيل ولم جزيل الشكر حساب.xlsm

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

السلام عليكم ورحمة الله وبركاته ارجو المساعدة في نقل صف كامل الى ورقة اخرى عندما تكون قيمة الخلية محددة وفي ملفي عندما تكون قيمة الخلية منفذ تنتقا تلقائيا الى الورقة الثنية وشكرا لكم مسبقا على المساعدة علما انني استخدمت هذا الكود ولم يعمل Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long Dim K As Long I = Worksheets("Sheet1").UsedRange.Rows.Count J = Worksheets("Sheet2").UsedRange.Rows.Count If J = 1 Then If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0 End If Set xRg = Worksheets("Sheet1").Range("C1:C" & I) On Error Resume Next Application.ScreenUpdating = False For K = 1 To xRg.Count If CStr(xRg(K).Value) = "منفذ" Then xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) xRg(K).EntireRow.Delete If CStr(xRg(K).Value) = "منفذ" Then K = K - 1 End If J = J + 1 End If Next Application.ScreenUpdating = True End Sub تطبيق طلبات.xlsx

السلام عليكم ورحمة الله وبركاته كيف يمكن ترحيل بيانات من ورقة إلى أخرى عن تحقق شرط معين مثلا في المرفق اريد تحويل الطلبات المنفذة إلى ورقة أخرى وهل يمكن تطبيق الدالة نفسها في كوكل شئت ولكم جزيل الشكر طلبات.xlsx

السلام عليكم ورحمة الله وبركاته المرفق الجمع المطلوب ضمن الملف جمع 2.xlsx

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

السلام عليكم ورحمة الله وبركاته اريد ان أجمع قيم عمود بشرط الفرق بين تاريخ اليوم وقبل 16 يوم بشكل دائم جمع.xlsx

جزاك الله خيرا

السلام عليكم ورحمة الله وبركاته استخدام دالة الجمع بشرط مادة معينة وشرط تاريخ اليوم ارجو المساعدة في إيجاد مجموع مادة معينة بتاريخ اليوم ولكم جزيل الشكر ‏‏‏‏انتاج.xlsx

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

Sub Button1_Click() On Error Resume Next If Range("a13") = "" Or Range("b13") = "" Or Range("c13") = "" Then MsgBox "ÈÑÌÇÁ ÇßãÇá ÇáÈíÇäÇÊ", vbDefaultButton1, "ßæÏ ÇáÊÑÍíá " Else azsh = ãÈíÚÇÊ.Range("c50000").End(xlUp).Row + 1 æÇÌåÉ.Range("A3:AA13").Copy ãÈíÚÇÊ.Cells(azsh, 1).PasteSpecial Paste:=xlPasteValues MsgBox "Êã ÈäÌÇÍ", vbDefaultButton1, "ßæÏ ÇáÊÑÍíá " æÇÌåÉ.Range("A13:AA13") = "" End If End Sub مشكور هذا الكود ترحيل1.xlsm

السلام عليكم ورحمة الله وبركاته ارجو المساعدة في تصحيح الخطأ في عملية الترحيل ترحيل1.xlsm