حسونة حسين

لطفا ارفق ملف

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل Test.xlsb

وعليكم السلام ورحمة الله وبركاته تفضل البحث عن طريق التيكست بوكس او الخليه e3 ثم تعبئه الليست بوكس بالاسماء ثم عند الضغط على اي سطر في الليست بوكس تنتقل البيانات الي الاماكن المطلوبه Private Sub TextBox1_Change() Test TextBox1 End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$E$3" Then Test Sheet2.Range("$E$3") End Sub Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ListBox1_Click End Sub Private Sub ListBox1_Click() Dim I As Long, M As Long, J As Long M = 0 For I = 0 To ListBox1.ListCount If ListBox1.Selected(I) = True Then For J = 5 To 10 Step 2 Sheet2.Cells(J, "D").Value = ListBox1.List(I, M) Sheet2.Cells(J, "G").Value = ListBox1.List(I, M + 3) M = M + 1 Next J End If Next I End Sub Sub Test(Search As Object) Dim A As Long, lrw As Long, C As Range ListBox1.Clear ListBox1.ColumnCount = 7 ListBox1.ColumnWidths = "60,0,0,0,0,0,1" lrw = Sheet3.Cells(Rows.Count, 1).End(xlUp).Row For Each C In Sheet3.Range("a2:a" & lrw) If Search = "" Then GoTo 1 If C Like Search & "*" Then ListBox1.AddItem For I = 0 To 5 ListBox1.List(A, I) = Sheet3.Cells(C.Row, I + 1).Value Next I A = A + 1 End If Next C 1 End Sub

وعليكم السلام ورحمة الله وبركاته تفضل Sub test() Dim X X = Application.Match(range("c5"), Columns(7), 0) If Not IsError(X) Then Cells(x , "H") = range("D5").Value Else Msgbox "لا يوجد هذا الاسم" End if End sub

وعليكم السلام ورحمة الله وبركاته جرب هذا التعديل تم اضافه next i في السطر الرابع من اسفل الكود Private Sub CommandButton5_Click() Dim WS As Worksheet, LastRow As Long Set WS = ThisWorkbook.Sheets("ãÎÒä (2024)") If TextBox2.Text = "" Then MsgBox "Þã ÇæáÇ ÈÇÎÊíÇÑ ãæÙÝ áÊÚÏíáå Çæ ÍÐÝå", vbExclamation, "ÍÐÝ" Exit Sub End If LastRow = WS.Cells(Rows.Count, "B").End(xlUp).Row + 1 Dim Q Q = MsgBox(" ÃäÊ Úáì æÔß ÍÐÝ ÇáÇÓã " & " ( " & TextBox2.Text & " ) " & " ãä ÇáÓÌá ¡ åá ÊÑíÏ ÇáãæÇÕáÉ ", vbCritical + vbYesNo, "ÊÃßíÏ ÇáÍÐÝ") If Q = vbYes Then For i = 2 To 12 For T = 2 To LastRow If TextBox2.Text = WS.Cells(T, 2) Then With WS .Cells(T, i).Value = "" .Rows(T).Delete Shift:=xlUp End With End If Next t Next i MsgBox " áÞÏ Êã ÍÐÝ ÇáãæÙÝ " & TextBox2.Text & " ãä ÞÇÚÏÉ ÇáÈíÇäÇÊ ", vbInformation, "" End If For i = 2 To 12 Me.Controls("TextBox" & i).Value = "" next i Me.ComboBox1.Clear TextBox2.SetFocus End Sub

اولا محرر الاكواد محمي بباسورد ثانيا ما هى اسم الصفحه التي بها المشكله؟ ثالثا هل المشكله انه يعطيك هذه الرساله رابعا بيانات الرقم القومى تدل على الاتى: الرقمان الثامن والتاسع من اليسار (٢١) يدلوا على محافظه الجيزة وهو موجود فعلا عندك في عامود محافظه الميلاد في صفحه خدمات الرقم الثالث عشر رقم (٣) رقم فردى فهو ذكر وتاريخ الميلاد مظبوط اري ان النتائج سليمه اين المشكله

تفضل اخى Sub Merge_Sheets() Dim Sht As Worksheet Dim Sht6 As Worksheet Dim LastRow6 As Long Dim Rng As Range Set Sht6 = Sheets("DataT1") 'Loop though B1DataT1 - B2DataT1 - B3DataT1 For Each Sht In Sheets(Array("B1DataT1", "B2DataT1", "B3DataT1")) 'Find last row LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Determine lastrow on DatatT1 LastRow6 = Application.Max(3, Sht6.Cells(Rows.Count, 1).End(xlUp).Row + 1) 'Set Range Set Rng = Sht.Range("A3:Q" & LastRow) 'Copy to DataT1 Rng.Copy Destination:=Sht6.Range("A" & LastRow6) Next End Sub ولا تنسي ان تمسح البيانات الموجوده في الشيت Sht6 لان بها بيانات تتعدى ال ٣٠٠٠ السطر

ماذا تقصد ؟

وفيك بارك اخى خيري

وعليكم السلام ورحمة الله وبركاته طريقه Mr.Columns("i:xfb").Hidden = True وايضا range("i:xfb").EntireColumn.Hidden = true

وعليكم السلام ورحمة الله وبركاته عدل Rng.Copy Destination:=Sht6.Range("A3:Q" & LastRow6 + 2) الى Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2 & ":Q" & LastRow6 + 2)

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

اخى @علي بن علي ابو عبدالرحمن ارفق ملفك بعد وضعك للكود الذي به المشكله

بارك الله فيك استاذ ضاحي

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

افتح الفورم وضع هذا الكود بها

اخى @علي بن علي ابو عبدالرحمن الكود الذي موجود في افضل اجابه يعمل جيدا وليس به مشاكل والكود الذي المشاركه الاخيره لاخي @محمد يوسف ابو يوسف يعمل ايضا وليس به مشاكل

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

اخى @طارق نادر قم بقراءه المشاركه جيدا ستجد انني كاتب لك الخطوات جيدا اين الخطوة التي بها صعوبه حتى اشرحها لك

جرب هذا التعديل Private Sub Worksheet_Activate() Range("M5:M17").value = Range("G5:G17").value End Sub

ضع هذا الكود في حدث الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Range("D2").Value = Range("A1").Value End Sub

بارك الله فيك اخى @وجيه شرف الدين وجعله الله في ميزان حسناتكم

بارك الله فيك اخى @ابراهيم الحدادوجعله الله في ميزان حسناتك

حل مشكله اللغه العربيه وايضا رابط

تنسيق الخليه عندك معمول text اجعله general وسوف يعمل الكود تفضل invoice ss new (1).xlsm