حسين مامون

ضع الكود في الليست بوكس Private Sub ListBox1_Click() TextBox1.Value = ListBox1.Column(0) TextBox2.Value = ListBox1.Column(1) TextBox3.Value = ListBox1.Column(2) TextBox4.Value = ListBox1.Column(3) TextBox5.Value = ListBox1.Column(4) TextBox6.Value = ListBox1.Column(5) TextBox7.Value = ListBox1.Column(6) End Sub

جزاك الله خيرا

ضع هذا الماكرو في مديول غير اسم الشيت الديون الى data1 واسم الشيت العملاء data2 او غير رهما في الماكرو الى العربي في الصف الثالث والرابع Sub test() Dim ws As Worksheet Dim ws2 As Worksheet Set ws = Sheets("data1") Set ws2 = Sheets("data2") Dim lr, lr2, x, xx, x1, x2, y Application.ScreenUpdating = False lr = ws.Cells(Rows.Count, "c").End(3).Row lr2 = ws2.Cells(Rows.Count, "b").End(3).Row For xx = 2 To lr2 For x = 6 To lr If ws2.Cells(xx, "b").Text = ws.Cells(x, "c") Then x1 = x1 + Val(ws.Cells(x, "e")) x2 = x2 + Val(ws.Cells(x, "g")) End If ws2.Cells(xx, "c") = x1 - x2 Next x1 = 0 x2 = 0 Next Application.ScreenUpdating = True End Sub

واصل رعاك الله وسدد خطاك

تفضل test (2).xlsm

على ما فهمت من طلبك تريد ترحيل بيانات كل موظف في شيت خاص به

اين الملف ارفع نمودج لملف العمل وضع البيانات كما تتوع ان تكون في النهاية

وهذا في حدث الشيت ان كان اليبل والتيكست بوكس على صفحة العمل Private Sub Worksheet_Activate() If Label1.Caption = "" Then TextBox1.Visible = False Else TextBox1.Visible = True End If End Sub

هذه تجربة ولكن ليس في ملفك ملفك لايريد ان يفتح عندي Book1.xlsm او ضع هذا الكود في حدث الفورم Private Sub UserForm_Initialize() If Label1.Caption = "" Then TextBox1.Visible = False Else TextBox1.Visible = True End If End Sub

جرب المرفق my_test.rar

سأعدل الكود غدا ان شاء الله ولكن تريد تترحل بناءا على ماذا ؟ مثلا ادا كان خلية العمود m فارغة لا يرحل الصف اجيب من الهاتف

بالنسبة للترحيل من ملف لاخر هناك زر ترحيل في شيت1 بالملف الاول اما الترحيل الى الشيتات الاخرى يجب عليك انشاء الصفحات كما تريد وضع بعض البيانات فيها كنمودج نهائي للعمل وارفعه مع شرح المراد في المرفق فك الضغط ستجد مجلد "my_test"ضعه كما هو في اي فولدر تريد my_test.rar

اخي الكريم على الاقل ارفع صورة لصفحة العمل و صورة للفورم

ضع هذا الكود في TEXTBOX3 ادخل الاسم المراد وانقر زر ادخال على لوحة المفاتيح Private Sub textbox3_AfterUpdate() Dim ws As Worksheet Set ws = Sheets("مزارعين") Dim lr Dim x lr = ws.Range("b" & Rows.Count).End(xlUp).Row For x = 2 To lr If textbox3.Text = ws.Cells(x, 2) Then textbox2.Value = ws.Cells(x, 1) Exit For End If Next x End Sub

بعد اذن الاستاذ هذا الكود يطبع جميع الشيتات باستثناء شيت DATA ويمكنك تعديله حسب المدى المطلوب sub test 'كود طباعة جميع الشيتات dim ws as worksheet dim sh as worksheet: set sh = sheets("DATA") ' الشيت المستثنى من الطباعة Dim lr As Long For Each ws In Sheets lr = ws.Range("a" & Rows.Count).End(xlUp).Row If ws.Name = "DATA" Then GoTo 1 ' الشيت داتا سميه ما شئت ولك غيره في السطر الثاني و السادس ws.Range("a1:g" & lr).PrintOut 1: Next ws end sub

تفضل ولاكن لايمكن العمل على التخمين بدون رفع ملف العمل Book1 (Recovered).xlsm

ارفق صورة لصفحة العمل وصورة للفورم

اين ملف العمل

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

استاذ محمد المفترس ارى انك لم تضع بعض البيانات في ملفك ليفهم الاساتذة اين يبدأ واين ينتهي وكذلك صفحة العميل اين اسم العميل وكود العميل اظن انه لن يجيبك احد هكذا حاول اعادة ظبط قواعد البيانات لديك ووضع بعض النتائج كما تريد ان تكون في النهاية تحياتي صفحة الترحيل صفحة العملاء

جزاك الله خيرا

تفضل جرب المرفق اضافة بيانات لليست عن طريق تكستات بزر اضافة.xls

اخي الكريم ربما تنفذ الكود من شيت اخر غير ش1يسبب هذا غير كلمة select ب activateوجرل ان لم ينجح هذا امسح هذا السطر وجرب جرب هذا العمل ان اعجبك نستمر في الباقي ان شاء الله ولكن هناك تغيير في شكل الفورم واضافات اخرى ستكتشفها ان شاء الله back.rar

بعد اذن استاد الـعيدروس قم بتعديل الكود في حدث textbox1 Private Sub TextBox1_Change() On Error GoTo 1 Dim ws As Worksheet: Set ws = Sheets("sheet1") Dim x, c Application.ScreenUpdating = False ListBox1.Clear For Each x In ws.Range("a4:a100000") c = InStr(x, TextBox1.Value) If c > 0 Then ListBox1.AddItem x With Me.ListBox1 .ColumnCount = 2 .List(i, 0) = x .List(i, 1) = x.Offset(0, 1) .List(i, 3) = x.Offset(0, 1).Address i = i + 1 End With End If Next x Application.ScreenUpdating = True 1: End Sub

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