محمد هشام.

وعليكم السلام ورحمة اللع تعالى وبركاته حاول اخي تضع نمودج او عينة للنتائج المتوقعة ومكان استخراجها لمزيدا من التوضيح

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

تفضل اخي https://streamable.com/dqdtjq

السلام عليكم ورحمة الله تعالى وبركاته .. اليك الاجابة والافادة معا . مع تعديل برنامجك ليتناسب مع طلبك . Private Sub Add_Click() '''''اضافة البيانات الى الليست بوكس''''' Dim MH As Variant, n As Byte If txtName.Value = Empty Then MsgBox "Please Enter Name": txtName.SetFocus: Exit Sub If txtJob.Value = Empty Then MsgBox "Please Enter Job": txtJob.SetFocus: Exit Sub If txtSallary.Value = Empty Then MsgBox "Please Enter Sallary": txtSallary.SetFocus: Exit Sub MH = Array(txtName.Value, txtJob.Value, txtSallary.Value, txtDate.Value) lstStItems.ColumnCount = 3 If lstStItems.ListCount <= 0 Then lstStItems.Column = MH Else lstStItems.AddItem MH(0) For n = 1 To 3 lstStItems.List(lstStItems.ListCount - 1, n) = MH(n) Next n End If txtName.Value = "" txtJob.Value = "" txtSallary.Value = "" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Fill_Click() '''''ترحيل البيانات من الليست بوكس الى التيكست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems txtName.Value = .List(.ListIndex, 0) txtJob.Value = .List(.ListIndex, 1) txtSallary.Value = .List(.ListIndex, 2) End With Else MsgBox " !المرجوا تحديد الصف ", vbCritical, "" End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Update_Click() '''''تعديل البيانات على الليست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems .List(.ListIndex, 0) = txtName.Value .List(.ListIndex, 1) = txtJob.Value .List(.ListIndex, 2) = txtSallary.Value End With Else MsgBox "!المرجوا تحديد الصف المراد تعديله ", vbCritical, "" End If End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Delete_Click() If lstStItems.ListIndex = -1 Then '''''حدف البيانات من الليست بوكس''''' MsgBox "!المرجوا تحديد الصف المراد حدفه !", vbCritical, "" Exit Sub End If If lstStItems.ListIndex >= 0 Then cevap = MsgBox("?هل انت متاكد من حدف البيانات", vbYesNo) If cevap = vbYes Then lstStItems.RemoveItem lstStItems.ListIndex End If End If End Sub Enter Data_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ...تفضل اخي Sub creation_onglets_MH() Dim contenu As String Dim lig As Long, MH As Long Dim ws As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next For Each ws In Worksheets If ws.Name <> "data" Then ws.Delete Next ws With Sheets("data") MH = .Range("E" & Rows.Count).End(xlUp).Row For lig = 4 To MH contenu = .Cells(lig, 5).Value If contenu = "" Then GoTo Suite If FeuilleExiste(ThisWorkbook, contenu) Then .Rows(lig).Copy Sheets(contenu).Range("A" & Rows.Count).End(xlUp).Offset(1, 0) Else Sheets.Add ActiveSheet.Name = contenu .Rows(1).Copy Sheets(contenu).Range("A3") .Rows(lig).Copy Sheets(contenu).Range("A4") With .Range("A:E") .HorizontalAlignment = xlCenter Range("a:a").ColumnWidth = 5 Range("b:b").ColumnWidth = 28.71 Range("c:c,d:d").ColumnWidth = 10 Range("E:E").ColumnWidth = 13 Dim i For i = 4 To 100 If ws.Name <> "data" Then Rows(i).RowHeight = 33 End If Next i End With End If Suite: Next lig Sheets("data").Activate NbSheet = ActiveWorkbook.Sheets.Count Range([A3], [IV3].End(xlToLeft)).Select Set MaPlage = Selection [A1].Select For NS = 1 To NbSheet Set Destination = ActiveWorkbook.Sheets(NS).Range("A3") MaPlage.Copy Destination Next NS Sheets("data").Move Before:=Sheets(1) Application.DisplayAlerts = True Application.ScreenUpdating = True End With End Sub Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean On Error Resume Next FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing) End Function move row_MH.xlsm

أخي ضع الكود في حدث شيت data

تفضل اخي Private Sub CommandButton1_Click() Dim lr As Integer Dim ws As Worksheet Set ws = Sheet2 With ws lr = .Cells(Rows.Count, 3).End(xlUp).Row .Range("h" & lr + 1).Value = Me.TextBox1.Value .Range("f" & lr + 1).Value = Me.TextBox2.Value .Range("c" & lr + 1).Value = Me.TextBox3.Value End With Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox1.SetFocus End Sub 1محل.xlsm

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

السلام عليكم ورحمة الله تعالى وبركاته اليك حل اخر بالاكواد Sub Count_cells_if() Dim MH As Variant Dim ws As Worksheet Set ws = Worksheets("sh1") Range("A10:D10").ClearContents On Error Resume Next MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("a" & Application.WorksheetFunction.Match(Range("f3"), _ Range("a1:a9"), 0) & ":a9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("a10") = MH '''''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("B" & Application.WorksheetFunction.Match(Range("f3"), _ Range("B1:B9"), 0) & ":B9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("B10") = MH '''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("C" & Application.WorksheetFunction.Match(Range("f3"), _ Range("C1:C9"), 0) & ":C9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("C10") = MH ''''''''''''''''''''''''''''''''''''''''' MH = 0: MH = Application.WorksheetFunction.CountIf(ws.Range("D" & Application.WorksheetFunction.Match(Range("f3"), _ Range("D1:D9"), 0) & ":D9"), "<=" & ws.Range("f3")) If MH <> 0 Then ws.Range("D10") = MH On Error GoTo 0 End Sub ورقة عمل Microsoft Excel جديد (1).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي Private Sub CommandButton1_Click() Dim lr As Integer Dim ws As Worksheet Set ws = Sheet4 With ws lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("a" & lr + 1).Value = Me.TextBox2.Value .Range("b" & lr + 1).Value = Me.TextBox3.Value .Range("c" & lr + 1).Value = Me.TextBox4.Value .Range("d" & lr + 1).Value = Me.TextBox5.Value .Range("e" & lr + 1).Value = Me.TextBox6.Value End With Me.TextBox2.Value = "" Me.TextBox3.Value = "" Me.TextBox4.Value = "" Me.TextBox5.Value = "" Me.TextBox6.Value = "" Me.TextBox2.SetFocus End Sub

وعليكم السلام ورحمة الله تعالى وبركاته اخي لم تحدد مكان وضع صورة البطاقة !!!!!...اما بالنسبة للصورة الشخصية يمكنك استخدام المعادلة التالية : =INDEX('ادخال البيانات'!$B$8:$C$300;EQUIV('فورم البيانات'!$B$10;'ادخال البيانات'!$C$8:$C$300;0);1) تجريبى.xls

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub Data_Transfer() On Error GoTo Fin Application.ScreenUpdating = False Dim MH%, MH2%, F MH = [A65500].End(xlUp).Row For Each F In Worksheets If F.Name <> "Input" Then With Sheets(F.Name) .Range("A1:E10000").ClearContents .Cells(1, 1) = F.Name: .Cells(1, 2) = "Kg": .Cells(1, 3) = "€" End With End If Next F For L = 2 To MH Feuille = Cells(L, "A") If Feuille = "" Then Exit Sub With Sheets(Feuille) .Cells(.[C65500].End(xlUp).Row + 1, 2) = Cells(L, 3) .Cells(.[C65500].End(xlUp).Row + 1, 3) = Cells(L, 5) End With Next L Exit Sub Fin: MsgBox "The sheet " & Cells(L, "A") & " does not exist." End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub clear() Dim ws As Worksheet For Each ws In Worksheets If ws.Name <> "Input" Then ws.Range("a1:c1000").ClearContents End If Next ws End Sub Kopie von obst_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي صراحة لم تواجهني اي مشكلة !!!!! Classeur1.pdf

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

العفو اخي الكريم .وأي إستفسار أو إضافة لا تتردد في طلبها ..بالتوفيق

تفضل اخي الكريم بصراحة حاولت اساعدك لدرجة اني قمت تقريبا باعادة تصميم برنامجك!!!! واتمنى ان يلبي طلبك ولك اخي الفاضل الاكواد المستخدمة ربما يستفيد منها احد الاعضاء تذكير بتاريخ الاستحقاق_MH.xlsm

If Left(Sheet1.Cells(ss, "d").Value, a) = Left(Me.TextBox1.Text, a) Or Left(Sheet1.Cells(ss, "d").Value, a) < Left(Me.TextBox1.Text, a) Then جرب اخي تذكير بتاريخ الاستحقاق(1).xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..بعد ادن الاستاد ابراهيم الحداد آخر قيمة بشرط.xlsx

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي الكريم هدا حل اخر بالاكواد مع بعض الاضافات البسيطة ربما يلبي طلبك في حدث شيت Nesma Private Sub Worksheet_Activate() Dim li As Integer, MH1 As Integer, A As Integer, Y As Integer A = Sheets("Parts").Range("G" & Rows.Count).End(xlUp).Row Y = Sheets("Parts").Cells(2, Cells.Columns.Count).End(xlToLeft).Column + 1 Application.ScreenUpdating = False Worksheets("Nesma").Range("A4:C1000").ClearContents For li = 5 To A For MH1 = 3 To 3 Sheets("Nesma").Cells(li - 1, MH1) = Sheets("Parts").Cells(li, MH1) Sheets("Nesma").Cells(li - 1, MH1 - 1) = Sheets("Parts").Cells(li, MH1 + 3) Sheets("Nesma").Cells(li - 1, MH1 - 2) = Sheets("Parts").Cells(li, MH1 + 4) Next Next Application.ScreenUpdating = True End Sub وهدا في حدث شيت Wheels Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long Application.ScreenUpdating = False Worksheets("Parts").Range("G5:G1000").ClearContents With Sheets("Wheels") lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row .Range(.Cells(4, "b"), .Cells(lr, "b")).Copy Sheets("Parts").Cells(5, "G") .Range(.Cells(4, "c"), .Cells(lr, "c")).Copy Sheets("Parts").Cells(5, "f") End With Application.ScreenUpdating = True End Sub OR_more_100 values_MH.xlsm

ربما قد قمت بتغيير تنسيقات احدى الخلايا في جدول البيع .!!!!!! يمكنك الرجوع للملف الدي سبق وان رفعته لك ليس به اي مشكلة عند الترحيل على العموم قد تم اصلاح الملف وتفاديا لحصول نفس المشكلة معك في مرة مقبلة يمكنك تطويع الكود الاول ليؤدي نفس المهمة باضافة هدا السطر حيث يتم اضافة المعادلة في عمود الفرق اثناء الترحيل .Cells(DL, "P").Formula = "=IFERROR(IF(RC[-14]="""","""",RC[-8]-RC[-4]-RC[-2]),"""")" 4_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته اولا طريقة تصميمك للملف غير صالحة لاستخراج البيانات بشكل سليم . تفضل اخي قد تم تعديل الملف ليتناسب مع طلبك مع اضافة المعادلات لاستخراج نتائج شهور السنة كاملة. اضافة لجدول في Sheet3 يمكنك من العثور على النتيجة المطلوبة من خلال اختيار اسم الشهر عبر ComboBox Book1_MH.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته نعم اخي ممكن بتعديل بسيط للمجال المنسوخ واضافة عمود يتضمن اسم الملف او (القسم) داخل اوراق العمل المستورد منها البيانات. وهده صورة للنتائج بعد تعديل الكود ملاحظة: بالنسبة لهدا الموضوع اخي الكريم ادا لم اكن مخطأ فهو نفس الفكرة ولربما افضل من وجهة نظري سواءا من ناحية النتائج .او امكانية العمل على ملف واحد فقط بدل كثرة الملفات .....هدا في حالة لم تكن هناك ضرورة لدالك الملفات.zip

اسف اخي -تفضل 12_mh.xlsm

تفضل اخي 2_MH.xlsm

بعد ادن الاستاد عبدالفتاح في بي اكسيل ..اليك حل اخر يغنيك عن اضافة ازرار اخرى Option Explicit Private Sub CheckBox1_Click() Call ForAllCheckBoxes(CheckBox1) End Sub Private Sub CheckBox2_Click() Call ForAllCheckBoxes(CheckBox2) End Sub Private Sub CheckBox3_Click() Call ForAllCheckBoxes(CheckBox3) End Sub Private Sub CheckBox4_Click() Call ForAllCheckBoxes(CheckBox4) End Sub Private Sub CheckBox5_Click() Call ForAllCheckBoxes(CheckBox5) End Sub Private Sub ForAllCheckBoxes(ChkBox As Control) Dim fndHead As Range, col As Long If ChkBox.Value = True Then With Sheets("Sheet2") Set fndHead = .Range("1:1").Find(What:=ChkBox.Caption, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, MatchCase:=False) If Not fndHead Is Nothing Then MsgBox "The " & ChkBox.Caption & " column already exists" & vbLf & _ "You need to uncheck to remove existing first" Exit Sub End If End With With Sheets("Sheet1") Set fndHead = .Range("1:1").Find(What:=ChkBox.Caption, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, MatchCase:=False) If Not fndHead Is Nothing Then .Columns(fndHead.Column).Copy Else MsgBox ChkBox.Caption & "Not found" Exit Sub End If End With With Sheets("Sheet2") If .Cells(1) = "" Then col = 1 Else col = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 End If .Columns(col).PasteSpecial End With Application.CutCopyMode = False Else With Sheets("Sheet2") Set fndHead = .Range("1:1").Find(What:=ChkBox.Caption, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, MatchCase:=False) If Not fndHead Is Nothing Then .Columns(fndHead.Column).Delete End If End With End If End Sub check column.xlsm