حسونة حسين

الحمد لله الذي بنعمته تتم الصالحات

وجزاكم مثله اخى الحمد لله الذي بنعمته تتم الصالحات

اطلع علي هذا الموضوع لعل فيه ما تبغي

وجزاكم مثله اخى

آمين يارب العالمين الشكر لله والحمد لله الذي بنعمته تتم الصالحات

امين يارب العالمين عدل Lr = .Cells(Rows.Count, 5).End(xlUp).Row الى Lr = 200 ' او اي رقم تريده

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

لطفا ارفق ملف

وعليكم السلام ورحمه الله وبركاته جرب هذا التعديل 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)

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

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

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

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

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

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

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