محمد هشام.

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

العفو اخي الكريم اليك حل اخر في حالة الرغبة بنسخ المعادلات Sub Copy() Application.ScreenUpdating = False Dim i As Long, v As Variant, srcWS As Worksheet, cnt As Long, lRow As Long Set srcWS = Sheets("رئيسيه") lRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row v = srcWS.Range("X10", srcWS.Range("X" & Rows.Count).End(xlUp)).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(v, 1) If Not .Exists(v(i, 1)) Then .Add v(i, 1), Nothing Sheets(v(i, 1)).Range("B10:P1000").ClearContents With srcWS .Range("N8:AD" & lRow).AutoFilter Field:=11, Criteria1:=v(i, 1) cnt = .[subtotal(103,N:N)] - 1 .Range("N10:V" & lRow).SpecialCells(xlCellTypeVisible).Copy Sheets(v(i, 1)).Range("B10") .Range("Z10:AB" & lRow).SpecialCells(xlCellTypeVisible).Copy Sheets(v(i, 1)).Range("L10") Sheets(v(i, 1)).Range("P10:P" & 9 + cnt).Formula = "=IFERROR(IF(RC[-14]="""","""",RC[-8]-RC[-4]-RC[-2]),"""")" End With End If Next i End With srcWS.Range("N8").AutoFilter Application.ScreenUpdating = True End Sub

تفضل اخي الكريم Sub ترحيل() Application.ScreenUpdating = False For L = 10 To Range("X65500").End(xlUp).Row MH = Cells(L, "X") If FeuilleExiste(MH) = False And MH <> "" Then MsgBox "المرجوا التحقق من وجود اوراق الوكلاء " Exit Sub End If ' افراغ Sheets(MH).Range("B10:P1000").ClearContents Next L For L = 10 To Range("X65500").End(xlUp).Row MH = Cells(L, "X") With Sheets(MH) DL = .Range("B65500").End(xlUp).Row If DL = 8 Then DL = 9 'نبدا من الصف 10 DL = DL + 1 .Cells(DL, "B") = Cells(L, "N") 'التاريخ .Cells(DL, "D") = Cells(L, "P") 'الوزن (طن ) .Cells(DL, "F") = Cells(L, "R") 'السعر .Cells(DL, "H") = Cells(L, "T") 'المبلغ .Cells(DL, "J") = Cells(L, "V") 'المجهز .Cells(DL, "L") = Cells(L, "Z") 'اجور النقل .Cells(DL, "N") = Cells(L, "AB") 'السماح .Cells(DL, "P") = Cells(L, "AD") 'الفرق End With Next L End Sub Function FeuilleExiste(FeuilleAVerifier) Dim Feuille As Worksheet FeuilleExiste = False For Each Feuille In Worksheets If UCase(Feuille.Name) = UCase(FeuilleAVerifier) Then FeuilleExiste = True Exit Function End If Next Feuille Exit Function SiErreur: MsgBox "Une erreur s'est MHe..." FeuilleExiste = CVErr(xlErrNA) End Function اضافة ورقة جديدة باسم وكيل جديد وتسميتها وفقا للتسلسل الموجود على الملف Sub انشاء_ورقةجديدة_MH() Dim Ind As Integer Dim FlgExist As Boolean, Test As String Application.ScreenUpdating = False Feuil2.Copy After:=Sheets(Sheets.Count) Ind = 1 Do On Error Resume Next Test = Sheets("وكيل" & Ind).Range("A1").Value If Err.Number = 0 Then FlgExist = True: Ind = Ind + 1 Else FlgExist = False Loop While FlgExist On Error GoTo 0 ActiveSheet.Name = "وكيل" & Ind Range("B10:P1000").ClearContents Dim rng As Range For Each rng In ActiveSheet.UsedRange If rng.HasFormula Then rng.Formula = rng.Value End If Next rng Feuil1.Select Application.ScreenUpdating = True End Sub sample_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ..تقضل اخي جرب 1_MH.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي Sub ضياء_test1() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(U2=""رئيسي"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(U2=""رئيسي"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End Sub او بهده الطريقة Sub ضياء_test2() LR = ActiveSheet.Cells(Rows.Count, "U").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & LR) .Formula = "=IF(RC[-5]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With With Range("AA2:AA" & LR) .Formula = "=IF(RC[-6]=""رئيسي"",IF(RC[-2]>=200,RC[-2]*3.6*24,IF(RC[-2]<=40,RC[-2]*3.6*16,IF(RC[-2]<200,RC[-2]*3.6*20))),RC[-2]*3.6*24)" .Value = .Value End With End Sub وبهده الطريقة بالنسبة لحدث الشيت Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect(Target, Range("x:y")) Is Nothing Then lr = ActiveSheet.Cells(Rows.Count, "u").End(xlUp).Row '''''''''''''''''''''''''''' With Range("Z2:Z" & lr) .Formula = "=IF(U2=""ورقة1"",IF(X2>=200,X2*3.6*24,IF(X2<=40,X2*3.6*16,IF(X2<200,X2*3.6*20))),X2*3.6*24)" .Value = .Value End With With Range("AA2:AA" & lr) .Formula = "=IF(U2=""ورقة1"",IF(Y2>=200,Y2*3.6*24,IF(Y2<=40,Y2*3.6*16,IF(Y2<200,Y2*3.6*20))),Y2*3.6*24)" .Value = .Value End With End If End Sub حساب.xlsm حساب _ حدث الشيت.xlsm

Book_MH_3.xlsm

تفضل اخي المسالة ليس لها علاقة بالكود التاريخ يتم احتسابه عن طريق معادلة . Book_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي Dim H, BT(), Rng, Ncol, MH1(), MH2(), MH3 Private Sub UserForm_Initialize() Set H = Sheets("BT") Set Rng = H.Range("A6:H" & H.[A65000].End(xlUp).Row) MH2 = Array(2, 3, 4, 5, 6) MH1 = Array(2, 3, 6, 4, 5) MH3 = 1 BT = Rng.Value Ncol = UBound(MH1) + 1 Me.ListBox1.ColumnWidths = temp & ";150" For i = Ncol + 1 To 5: Me("textbox" & i).Visible = False: Next i Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(BT) To UBound(BT) d(BT(i, MH3)) = "" Next i temp = d.keys Me.ComboBox1.List = temp Me.ComboBox1 = "*" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub B_résultat_Click() Set MH = Sheets("التصفية") MH.Range("B10:F100").ClearContents A = Me.ListBox1.List MH.[b10].Resize(UBound(A) + 1, UBound(A, 2) + 1) = A With ThisWorkbook.Worksheets("التصفية") Sheet4.Range("c3") = ComboBox1.Text .Range("c5").Value = CDate(Me.TextBox2.Value) .Range("c7").Value = CDate(Me.TextBox3.Value) End With End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub ComboBox1_Change() Sheet3.Range("P2") = ComboBox1.Text TextBox1.Value = Sheets("BT").Range("Q2").Value TextBox2.Value = Sheets("BT").Range("R2").Value TextBox3.Value = Sheets("BT").Range("S2").Value Dim Tbl(): ReDim Tbl(1 To Ncol + 1, 1 To UBound(BT)) ligne = 0 For i = 1 To UBound(BT) If BT(i, MH3) Like Me.ComboBox1 Then ligne = ligne + 1 c = 0 For Each k In MH1 c = c + 1: Tbl(c, ligne) = BT(i, k) Next k ' c = c + 1: Tbl(c, ligne) = i + Decal End If Next i ReDim Preserve Tbl(1 To Ncol + 1, 1 To ligne) Me.ListBox1.Column = Tbl End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub TriS(A, gauc, droi) ref = A((gauc + droi) \ 2) g = gauc: d = droi Do Do While A(g) < ref: g = g + 1: Loop Do While ref < A(d): d = d - 1: Loop If g <= d Then temp = A(g): A(g) = A(d): A(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call TriS(A, g, droi) If gauc < d Then Call TriS(A, gauc, d) End Sub Book_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته ..تفضل اخي الكريم Private Sub CommandButton1_Click() Dim filePath As String Dim Ws As Worksheet Application.ScreenUpdating = False filePath = Application.ActiveWorkbook.Path Set Ws = Sheets("بيانات") With Ws .Copy Application.DisplayAlerts = False Application.CutCopyMode = False Dim shape As Excel.shape For Each shape In ActiveSheet.Shapes shape.Delete Next Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & .Name & "" & "" & ".xlsx", FileFormat:=51 Application.ActiveWorkbook.Close False End With MsgBox "تم نسخ الملف بنجاح" Application.ScreenUpdating = True End Sub wor_MH.xlsm

السلام عليكم ورحمة الله تعالى وبركاته بالنسبة للكود يمكنك جعله بهده الطريقة اخي الكريم وسبب تاخيري عن الرد على طلبك هو انني كنت انتظر جوابك بخصوص كود المنتج لاكن للاسف جوابك غير مفهوم (كود المنتج يكتب آليا ) تتضمن عدة امور Private Sub CommandButton10_Click() If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("b:b"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If With ActiveSheet If .FilterMode Then .ShowAllData lr = .Cells(Rows.Count, 1).End(3).Row + 1 Cells(lr, 1).Resize(, 4) = Array(lr - 1, txt_product, txt_price_sale, txt_price_pru) End With Me.txt_product.Value = "" Me.txt_price_sale.Value = "" Me.txt_price_pru.Value = "" MsgBox "Done", vbtnformation End Sub اما الزيادة التي سبق ان وعدتك بها في المشاركة السابقة هي عبارة عن ملفك يتضمن جميع الاظافات التي من الممكن ان تحتاجها . ترحيل _ تعديل _ حدف _ بحث بكود المنتج Private Sub CommandButton9_Click() '''''''''ترحيل البيانات''''''''' ''الشرط الاول'' If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If ''الشرط الثاني'' If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If ''الشرط الثالث'' If IsNumeric(Me.txt_price_sale) = False Then MsgBox "الرجاء ادخال سعر البيع", vbCritical Exit Sub End If ''التحقق من وجود اسم المنتج مسبقا '' Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") If Application.WorksheetFunction.CountIf(sh.Range("B:B"), Me.txt_product.Value) > 0 Then MsgBox "هذا المنتج مضاف مسبقا", vbCritical Exit Sub End If ''''''''''' النطاق المرحل اليه'''''''''''' Dim lr As Long lr = Sheets("product_master").Range("B" & Rows.Count).End(xlUp).Row With sh .Cells(lr + 1, "b").Value = Me.txt_product.Value .Cells(lr + 1, "c").Value = Me.txt_price_pru.Value .Cells(lr + 1, "d").Value = Me.txt_price_sale.Value End With ''''''''افراغ textbox''''''' Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" ''''''''(A)ترقيم تلقائي لعمود '''''' ''مع امكانية حدف الصفوف '' Worksheets("product_master").Activate Application.EnableEvents = False With Range("a2:a" & Cells.Find("*", , , , xlByRows, xlPrevious).Row) .Formula = "=Row() - 1" .Value = .Value End With Application.EnableEvents = True MsgBox "تم الترحيل بنجاح", vbtnformation '' UserForm_تحديث '' Unload Me frm_product_master.Show End Sub '''''''''' البحث بكود المنتج'''''''''''' Private Sub CommandButton10_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then txt_product = Sheets("product_master").Cells(y, 2).Value txt_price_pru = Sheets("product_master").Cells(y, 3).Value txt_price_sale = Sheets("product_master").Cells(y, 4).Value End If Next y End Sub ''''''''''''''''تعديل البيانات'''''''''''''''' Private Sub CommandButton12_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txt_product.Value = "" Then MsgBox "الرجاء ادخال اسم المنتج", vbCritical Exit Sub End If If IsNumeric(Me.txt_price_pru) = False Then MsgBox "الرجاءادخال سعر شراءالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Sheets("product_master").Cells(y, 2).Value = txt_product Sheets("product_master").Cells(y, 3).Value = txt_price_pru Sheets("product_master").Cells(y, 4).Value = txt_price_sale End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم التعديل بنجاح", vbInformation End Sub ''''''''''''''''حدف صف معين'''''''''''''''' Private Sub CommandButton13_Click() Dim x As Long Dim y As Long x = Sheets("product_master").Range("A" & Rows.Count).End(xlUp).Row If Me.txtSearch.Value = "" Then MsgBox "الرجاء ادخال كودالمنتج", vbCritical Exit Sub End If For y = 2 To x If Sheets("product_master").Cells(y, 1).Value = txtSearch.Text Then Rows(y).Delete End If Next y Me.txtSearch.Value = "" Me.txt_product.Value = "" Me.txt_price_pru.Value = "" Me.txt_price_sale.Value = "" MsgBox "تم حدف البيانات بنجاح", vbInformation Call MH Unload Me frm_product_master.Show End Sub ''''''''''''''''UserForm _ تحديث واجهة '''''''''''''''' Sub Refresh_data() Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("product_master") Dim lr As Long lr = Sheets("product_master").Range("a" & Rows.Count).End(xlUp).Row If lr = 1 Then lr = 2 With Me.ListBox .ColumnCount = 4 .ColumnHeads = True .RowSource = "product_master!A2:d" & lr End With End Sub Private Sub CommandButton14_Click() If MsgBox("هل تريد الخروج من البرنامج", vbQuestion + vbYesNo, "Confirmation") = vbYes Then Unload Me End If End Sub Private Sub ListBox_DblClick(ByVal Cancel As MSForms.ReturnBoolean) txtSearch.Text = ListBox.Column(0) If txtSearch.Text = Me.ListBox.Column(0) Then Me.txt_product = Me.ListBox.Column(1) Me.txt_price_pru = Me.ListBox.Column(2) Me.txt_price_sale = Me.ListBox.Column(3) End If End Sub المحل_MH.xlsm

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

السؤال هل هناك رقم او رمز معين لكود المنتج او ترقيم تلقائي 1.2.3 إلى آخره

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

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي تم اضافة كود الفاتورة للصفحات الاربعة AA.xlsm

وعليكم السلام ورحمة الله وبركاته اتبع الخطوات التالية اخي https://streamable.com/yuhc88

العفو اخي الكريم تفضل هدا حل اخر Public Sub Filter_data() Dim lo As ListObject, rng As Range Dim rw As Long, i As Long Dim arrayCriteria() Set lo = Range("T_ID").ListObject rw = lo.ListRows.Count ReDim arrayCriteria(rw) For i = 1 To rw arrayCriteria(i) = CStr(lo.DataBodyRange.Cells(i, 1)) Next i Set rng = Range("T_data") With rng.ListObject If .ShowAutoFilter Then .AutoFilter.ShowAllData .Range.AutoFilter field:=1, Criteria1:=arrayCriteria, Operator:=xlFilterValues End With End Sub فلترة بنطاق معين.xlsm

الشيت غير مفهوم حاول وضع نموذج او عينة للنتائج المتوقعة

tb10 قيمه الفاتورة AAAAA(1).xlsm

تقصد نضيف الكود ترحيل tb10 إلى عمود K

موجودة في أي مكان؟

تفضل اخي مع اضافة كود زر الخروج AAAAA(1).xlsm