حسونة حسين

اخى الكريم اكتب موضوع جديد وبه سؤالك الجديد وستجد ان شاء الله اجابه لطلبك سواء منى او من الاساتذه

كل اسئلتك تتكلم عن البحث بالتاريخ وكود التاريخ كده مفيش اي مشكله صح اخى ولا خطأ؟

تفضل اخى الكريم جرب هذا الملف برنامج_ نمازج.xlsm

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

هنا الكود كاملا Option Explicit Sub Delete_Row_If_Equal_A_Specific_Value() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sPath As String, sFile As String Dim C As Range, M As Long, R As Long Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False Set SH = ThisWorkbook.Worksheets("Sheet1") sPath = ThisWorkbook.Path & "\222\" sFile = Dir(sPath & "*.xls*") Do While sFile <> "" Set WB = Workbooks.Open(sPath & sFile, False) For Each WS In WB.Worksheets M = SH.Range("A" & Rows.Count).End(xlUp).Row For R = 2 To M Set C = WS.Range("A:A").Find(What:=SH.Range("A" & R).Value, LookAt:=xlWhole) If C Is Nothing Or IsEmpty(C) Then GoTo 1 WS.Rows(C.Row).Delete 1 Next R Next WS WB.Close SaveChanges:=True sFile = Dir Loop Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True End Sub

اخى عدل هذا السطر If C Is Nothing Then GoTo 1 ليكون If C Is Nothing Or IsEmpty(C) Then GoTo وحاجه تانيه الملف الذي به الكود جميع الارقام التي به ليست موجوده في الملفات الموجوده في فولدر 222 في اخر ملف لك اما في الملف الاول لك في اول مشاركه الارقام موجوده ويحذفها

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

ارفق ملفك اخى بعد وضع الكود به

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

وعليكم السلام ورحمه الله وبركاته

تم التعديل اخى

ماذا الذي لم يعمل اخى

تفضل اخى الكود كاملا Private Sub CommandButton3_Click() Dim C As Range, SH As Worksheet, WS As Worksheet, A As String Set SH = ThisWorkbook.Worksheets("Sheet1") If SH.Range("I4").Value <> "" Then Set WS = ThisWorkbook.Worksheets("Sheet2") A = SH.Range("I4").Value Else Set WS = ThisWorkbook.Worksheets("Sheet4") A = WS.Range("L2").Value End If Set C = WS.Range("C:C").Find(What:=A, LookIn:=xlValues, LookAt:=xlWhole) With SH .Range("d6") = WS.Cells(C.Row, "b") .Range("d8") = WS.Cells(C.Row, "d") .Range("d10") = WS.Cells(C.Row, "e") .Range("d12") = WS.Cells(C.Row, "f") .Range("d14") = WS.Cells(C.Row, "g") .Range("d16") = WS.Cells(C.Row, "h") .Range("d18") = WS.Cells(C.Row, "i") .Range("g6") = WS.Cells(C.Row, "c") .Range("g8") = WS.Cells(C.Row, "j") .Range("g10") = WS.Cells(C.Row, "k") .Range("g12") = WS.Cells(C.Row, "l") .Range("g14") = WS.Cells(C.Row, "m") .Range("g16") = WS.Cells(C.Row, "n") .Range("g18") = WS.Cells(C.Row, "o") End With End Sub

تم التعديل من L4 الى L2 عذرا لانى اعمل عن طريق الموبايل

تم تعديل الكود

تفضل اخى الكريم ضع هذا الكود في ملف ( الميكرو المستخدم في التعديل علي الملفات.xlsx) فى موديل عادى ثم شغل الكود Option Explicit Sub Delete_Row_If_Equal_A_Specific_Value() Dim WB As Workbook, WS As Worksheet, SH As Worksheet, sPath As String, sFile As String Dim C As Range, M As Long, R As Long Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.EnableEvents = False Set SH = ThisWorkbook.Worksheets("Sheet1") sPath = ThisWorkbook.Path & "\الملفات\" sFile = Dir(sPath & "*.xls*") Do While sFile <> "" Set WB = Workbooks.Open(sPath & sFile, False) For Each WS In WB.Worksheets M = WS.Range("A" & Rows.Count).End(xlUp).Row For R = 2 To M Set C = WS.Range("A:A").Find(What:=SH.Range("A" & R).Value, LookAt:=xlWhole) If C Is Nothing Then GoTo 1 WS.Rows(C.Row).Delete 1 Next R Next WS WB.Close SaveChanges:=True sFile = Dir Loop Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.EnableEvents = True End Sub

وعليكم السلام ورحمة الله وبركاته تفضل اخى Private Sub CommandButton3_Click() Dim C As Range, SH As Worksheet, WS As Worksheet Set SH = ThisWorkbook.Worksheets("Sheet1") If SH.Range("I4").Value <> "" then Set WS = ThisWorkbook.Worksheets("Sheet2") a=SH.Range("I4").value else set WS = ThisWorkbook.Worksheets("Sheet4") a=ws.range("L2").value end if Set C = WS.Range("C:C").Find(What:=A, LookAt:=xlWhole) With SH .Range("d6") = WS.Cells(C.Row, "b") .Range("d8") = WS.Cells(C.Row, "d") .Range("d10") = WS.Cells(C.Row, "e") .Range("d12") = WS.Cells(C.Row, "f") .Range("d14") = WS.Cells(C.Row, "g") .Range("d16") = WS.Cells(C.Row, "h") .Range("d18") = WS.Cells(C.Row, "i") .Range("g6") = WS.Cells(C.Row, "c") .Range("g8") = WS.Cells(C.Row, "j") .Range("g10") = WS.Cells(C.Row, "k") .Range("g12") = WS.Cells(C.Row, "l") .Range("g14") = WS.Cells(C.Row, "m") .Range("g16") = WS.Cells(C.Row, "n") .Range("g18") = WS.Cells(C.Row, "o") End With End Sub تم التعديل

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

وعليكم السلام ورحمة الله وبركاته امسح هذه السطور اخى الكريم Application.PrintCommunication = False With Sheets("Sheet3").PageSetup .FitToPagesWide = 1 .FitToPagesWide = False End With Application.PrintCommunication = True

جرب هذا التعديل اخى الكريم Option Explicit Sub MyStuNames() Dim Rng1 As Worksheet, Rng2 As Worksheet, T As String, Y As Integer, X As Double, Cel As Range, i As Integer Application.ScreenUpdating = False Set Rng1 = Worksheets("StudNames"): Set Rng2 = Worksheets("Analysis") T = Rng2.[AB1] X = Application.CountIf(Rng1.Range("B:B"), T) Y = IIf(Range("LangCod") = 2, 5, 4) Rng2.Range("B8:C42") = Empty i = 1 For Each Cel In Rng1.Range("B2:B" & Rng1.Cells(Rows.Count, 2).End(xlUp).Row) If Cel = T Then Rng2.Cells(7 + i, "B").Value = i Rng2.Cells(7 + i, "C").Value = Rng1.Cells(Cel.Row, Y).Value i = i + 1 End If Next Application.ScreenUpdating = True End Sub

تفضل اخى الكريم sief.xls

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

وعليكم السلام ورحمة الله وبركاته ممكن فضلا ان ترفق ملف بسيط به وليكن ٢٠ سطر لكى يستطيع الاخوة ان يفهموا طلبك

السلام عليكم ورحمة الله وبركاته وبها نبدأ عدل هذا السطر iRow = ws.Cells(Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row الى iRow = ws.Cells(Rows.Count, 1) _ .End(xlUp).Offset(1, 0).Row +1

تفضل اخى الكريم عطيه يتم العد في العامود z وضع دوائر حمراء على الحصص ووضع عددها في العامود z.xls