محمد هشام.

أخي ضع الكود في حدث شيت 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

العفو اخي الكريم اليك حل اخر في حالة الرغبة بنسخ المعادلات 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