محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته نفضل اخي Private Sub CommandButton2_Click() Dim wbNew As Workbook Dim MH As String, ws As Worksheet Dim val As String Dim shape As Excel.shape MH = CStr(Sheets("الفاتورة").Range("B1")) val = Worksheets("الفاتورة").Range("a14") Application.ScreenUpdating = False Application.DisplayAlerts = False Sheets("الفاتورة").Select Worksheets("الفاتورة").Copy Set wbNew = ActiveWorkbook With Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Range("a3").Select End With For Each shape In ActiveSheet.Shapes shape.Delete Next Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("A14").Value = val ActiveWorkbook.SaveAs Filename:= _ "C:\Users\edb3\Desktop\" & MH & "-" & "فاتورة رقم" & ".xlsx", FileFormat:=51 ActiveWorkbook.Close Sheets("الفاتورة").Activate Range("b1").Value = Range("b1").Value + 1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents Range("a14").Formula = "=NumtoTxt(R[-1]C[6],""جنيهاً"",""قرشاً"")" Range("a3").Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Sub CommandButton3_Click() Range("b1").Value = Range("b1").Value + 1 Application.Dialogs(xlDialogPrinterSetup).Show ThisWorkbook.Sheets("الفاتورة").PrintOut copies:=1 Range("h4:h12").ClearContents Range("c4:c12").ClearContents Range("f4:f12").ClearContents End Sub حفظ فاتورة.xlsm

تفضل اخي الكريم خلية البحث (G3) 'البحث في عمود A,B Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("g3") Then cell.Interior.ColorIndex = 6 End If Next End Sub ''''''''''''''''''''''''''''''''''''''''' ' E,البحث عن القيمة في متسلسلة عمود 'وتغيير لون الكتابة Sub FindLoop() Dim strFirstAddress As String Dim rngFindValue As Range Dim rngSearch As Range Dim rngFind As Range Set rngFind = ActiveSheet.Range("E1:E100000") Set rngSearch = rngFind.Cells(rngFind.Cells.Count) Set rngFindValue = rngFind.Find(Range("g3"), rngSearch, xlValues) If Not rngFindValue Is Nothing Then strFirstAddress = rngFindValue.Address rngFindValue.Font.Color = vbRed Do Set rngFindValue = rngFind.FindNext(rngFindValue) rngFindValue.Font.Color = vbRed Loop Until rngFindValue.Address = strFirstAddress End If End Sub 298667823_.xlsm

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار معيار الفلترة في خانة (D1) او ادخاله يدويا لفلترة جميع الاوراق على نفس المعيار Sub Filter_Me() Dim ans As String Dim T As ListObject MH = Sheets("Drawing").Range("D1") For i = 1 To Sheets.Count For Each T In Sheets(i).ListObjects T.Range.AutoFilter Field:=1, Criteria1:=MH Next Next End Sub ''''الغاء الفلترة من جميع الاوراق Sub Remove_Filters_From_Workbook() Dim MH As Worksheet Dim lstObj As ListObject For Each MH In Worksheets For Each lstObj In MH.ListObjects lstObj.AutoFilter.ShowAllData Next lstObj Next MH End Sub New Microsoft Excel Worksheet_MH.xlsm

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

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