ابو .. عبدالرحمن

مشكورين جميعاً على هذه الجهود المبذولة واتمني ان يكتمل بقية الاوامر بالنسبة للبحث حتى الان لم يضبط معي

الله يعطيك العافية حاولت اعدل فيه حاجات وارتبه من بعض الاعمدة الناقصة حتى اصبح بهذا الشكل Private Sub CommandButton1_Click() ' تحديد الصفحة الأصلية Dim wsSource As Worksheet Set wsSource = ThisWorkbook.Sheets("الرئيسية") ' تحديد الصفحة الهدف Dim wsTarget As Worksheet Set wsTarget = ThisWorkbook.Sheets("البيانات") ' ترحيل البيانات Dim lastRow As Long lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row Dim searchRange As Range Set searchRange = wsTarget.Range("A2:A" & lastRow) ' نطاق البحث في الصفحة الهدف If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then ' نسخ رقم المعاملة إذا لم يتم العثور عليه في الصفحة الهدف wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1) wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2) wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3) wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4) wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5) wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6) wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7) wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8) wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9) wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10) wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11) wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12) wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 13) wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 14) wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 15) wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 16) wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 17) wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 18) wsSource.Range("C8").Value = "" wsSource.Range("C10").Value = "" wsSource.Range("C12").Value = "" wsSource.Range("C14").Value = "" wsSource.Range("C16").Value = "" wsSource.Range("C18").Value = "" wsSource.Range("F8").Value = "" wsSource.Range("F10").Value = "" wsSource.Range("F12").Value = "" wsSource.Range("F14").Value = "" wsSource.Range("F16").Value = "" wsSource.Range("F18").Value = "" wsSource.Range("I8").Value = "" wsSource.Range("I10").Value = "" wsSource.Range("I12").Value = "" wsSource.Range("I14").Value = "" wsSource.Range("I16").Value = "" wsSource.Range("I18").Value = "" Else ' استبدال البيانات إذا تم العثور على رقم المعاملة موجودًا بالفعل في الصفحة الهدف Dim foundRow As Range Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole) If Not foundRow Is Nothing Then wsTarget.Cells(foundRow.Row, 1).Value = wsSource.Range("C8").Value wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F8").Value wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F10").Value wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F12").Value wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F14").Value wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F16").Value wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("F18").Value wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I8").Value wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I10").Value wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I12").Value wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I14").Value wsTarget.Cells(foundRow.Row, 17).Value = wsSource.Range("I16").Value wsTarget.Cells(foundRow.Row, 18).Value = wsSource.Range("I18").Value End If End If End Sub ولكن باقي البحث والتعديل والحذف ملاحظة بعد الترحيل ما يمسح رغم اني عملت له اومر لمسح الخلايا بعد الترحيل لكن مازال فيه اشكالية اتمنى مواصلة العمل حتى يكتمل ولكم جزيل الشكر

السلام عليكم ورحمة الله وبركاته اخواني الكرام رفق لكم برنامج قمت بتصميمه على شكل صفحة رئيسية لإدخال البيانات وصفحة البيانات المدخلة ولكن لم استطع الوصول الى اكواد اتمكن من اكمال هذا البرنامج اتمنى من الخبراء اكمال الاكواد المطلوبة وهي : ( كود الترحيل (ادخال البيانات) ، كود التعديل ، كود البحث وقائمة البحث ، كود الطباعة لشيت البيانات ، كود الحذف ) بحيث يعمل البرنامج بالشكل الصحيح .... ولكم تحياتي وشكري برنامج المعاملات المالية.xlsm

مشكور يارك الله فيك رغم اني كنت اتوقع اني لم احتاج الى تغيير الفورم ولكن اشكرك على الاستجابة والمساعدة وتحياتي لك

بحث في الفورم.xlsb

السلام عليكم ورحمة الله وبركاته اخواني الكرام اريد مساعدة في تعديل هذا الامر Private Sub CommandButton1_Click() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets For Each f In ws.Range("a2:a1000") If f = TextBox1.Text Then ws.Select f.Select Exit For End If Next f Next ws ActiveCell.Value = TextBox1.Value ActiveCell.Offset(0, 1).Value = TextBox2.Value ActiveCell.Offset(0, 2).Value = TextBox3.Value ActiveCell.Offset(0, 3).Value = TextBox4.Value ActiveCell.Offset(0, 4).Value = TextBox5.Value ActiveCell.Offset(0, 5).Value = TextBox6.Value MsgBox "تم تعديل البيانات بنجاح" TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" TextBox4.Value = "" TextBox5.Value = "" TextBox6.Value = "" TextBox8.Value = "" End Sub Private Sub TextBox8_Change() ' TextBox1.Value = "" ' TextBox2.Value = "" ' TextBox3.Value = "" ' TextBox4.Value = "" ' TextBox5.Value = "" ' TextBox6.Value = "" ' TextBox7.Value = "" ' If TextBox8.Value = "" Then ListBox1.Clear: Exit Sub Dim x As Worksheet ListBox1.Clear k = 0 For Each x In ThisWorkbook.Worksheets ss = x.Cells(Rows.Count, 1).End(xlUp).Row For Each c In x.Range("a2:a" & ss) b = InStr(c, TextBox8) If b > 0 Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 1).Value ListBox1.List(k, 1) = x.Cells(c.Row, 2).Value ListBox1.List(k, 2) = x.Cells(c.Row, 3).Value ListBox1.List(k, 3) = x.Cells(c.Row, 4).Value ListBox1.List(k, 4) = x.Cells(c.Row, 5).Value ListBox1.List(k, 5) = x.Cells(c.Row, 6).Value ' ListBox1.List(k, 6) = x.Cells(c.Row, 7).Value k = k + 1 End If Next c Next x End Sub اريد يبحث في شيت واحد فقط ويكون البحث في نطاق الخلية a1 الى الخلية k1 بحيث يتم استخراج كلمة البحث من الخلية h5 h6 h7 ............. الى اخر الجدول ولكم جزيل الشكر

اخي اشرف اشكرك على الاستجابة وجزاك الله خير

السلام عليكم ورحمة الله وبركاته اخواني الكرام وخبراء الاكسيل المحترمين اريد معادلة تضاف لاي فورم بحيث اني كل ما اكتب في الفورم كان بحث او ترحيل تجعل الفورم بعدها فارغ من المعلومات

اتوقع بان عدم ظهور الفيرم بعد 10 ثواني ان معادلة الساعة التي يستمر نبضها خلال الوقت هي التي تجعل الشيت او البرنامج في حالة مستمر غير ساكنه لذلك اتوقع انها السبب والله اعلم

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

ممتاز حبيبي الله يعطيك العافية هذا المطلوب بارك الله فيك بقي حاجة واحدة فقط وهي تفعيل 10 ثواني او 30 ثانية في حالة السكون . وتظهر شاشة الفيرم تلقائي اذا كان ذلك ممكن

تمام بيض الله وجهك بجرب وان شاء الله تضبط معي واعذرني على الاطالة

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

السلام عليكم ورحمة الله وبركاته مازلت بالا نتظار