ياسر خليل أبو البراء

أخي وحبيبي في الله ياسر العربي المتميز ألف مبروك الترقية المتستحقة عن جدارة الخبرة ليست بعدد المشاركات إنما بإفادة الغير بحلول مميزة وإن شاء الله بردو جر رجل عشان تخرج ما بجعبتك ، وأنا متأكد ياما في الجراب يا عربي أعانك الله على فعل الخير وتقبل الله منا ومنكم صالح الأعمال تقبل تحياتي

أخي الكريم مصطفى أين المرفق الجديد بعد تعديله للعمل عليه؟

أخي الغالي ياسر العربي مشكور على مرورك العطر وكلماتك الرقيقة الطيبة ، وجزيت خيراً بمثل ما دعوت وإن شاء الله نستفيد جميعاً من خبرتك الواسعة (يا ما في الجراب يا عربي)

أخي الكريم ياسر إنت متأكد إن الكلام الجامد دا أنا قلته ..أنا معرفش أقول الكلام دا يا عم عموماً كلام جميل وكلام معقول مقدرش أقول حاجة عنه !! تقبل تحياتي

أخي الحبيب ياسر العربي الترقية نسبية ..يعني ممكن يترقى الملازم ويكون أركان حرب ايه المشكلة ..طالما إنه يستحق ومبروك عليك الترقية المستحقة عن جدارة تقبل تحياتي

سأحاول إن شاء الله غداُ لأني مرهق جداً الآن .. غداً نلتقي إذا لم يتدخل أحد الأخوة ويلبي طلبك الأخير .. بس الملف مش مضبوط بشكل كلي .. راجع الملف ستجد هناك ثلاثة أعمدة في البداية لكل معلم وبعد قليل ستجد عمودين فقط يرجى إعادة تصميم الملف للعمل عليه بشكل أفضل تقبل تحياتي

أخي الكريم واائل يا مكسل تدور جوا الكود على السطر اللي عليه العين إليك الكود بالكامل (بس مختار كدا هيزعل إنني اتدخلت في كوده ..عموماً أنا عارف إنه قلبه طيب وهيسامح) Sub SaveShtsAsBook() Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy") With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next MkDir MyFilePath For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1")) sh.Activate SheetName1 = ActiveSheet.Name SheetName2 = ActiveSheet.Name & "" & [c1] Cells.Copy Set NB = Workbooks.Add(xlWBATWorksheet) With NB With .ActiveSheet .Cells.PasteSpecial Paste:=xlAll .Cells.PasteSpecial Paste:=xlPasteValues .Name = SheetName1 [a1].Activate End With ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1) .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False .Close SaveChanges:=True End With .CutCopyMode = False Set NB = Nothing Next sh Sheets("SAles").Activate .ScreenUpdating = True .DisplayAlerts = True End With End Sub

أخي مختار كلنا تلامذة هنا في هذا الصرح وأنا أتعلم منك الكثير والكثير ..بارك الله فيك ومشكور على كلماتك الرقيقة في حقي وإن كنت لا أستحقها تقبل وافر ودي وتقديري واحترامي

أرجو أخي محمد أن تكون نجحت في تطبيق الخطوات ووضع قدمك على أول الطريق وإن شاء الله أي استفسار اسأل ولا تحرج أبداً مهما بدا السؤال بسيطاً أو تافهاً فالسؤال طريق المعرفة .. تقبل تحياتي

أخي الغالي سعد الفقير إلى الله الحمد لله الذي بنعمته تتم الصالحات لي سؤال : إنت كنت مسجل قبل كدا بالمنتدى باسم "سعد رفيع" أو شيء قريب من كدا؟ تقبل تحياتي وإلى لقاء في موضوع آخر ..

بارك الله فيك أخي الحبيب مختار فقط أضف سطر آخر للحفاظ على تنسيقات ورقة العمل قبل لصق القيم .Cells.PasteSpecial Paste:=xlAll .Cells.PasteSpecial Paste:=xlPasteValues

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

قم بتغيير الكود في حدث ورقة العمل إلى الشكل التالي Private Sub Worksheet_Activate() Set Coll = RefreshCollection() End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Arr, strAddress As String, lCol As Long If Not Intersect(Target, Union(Range("H4"), Range("K4"), Range("N4"), Range("Q4"), Range("T4"), Range("W4"), Range("Z4"), Range("AC4"), Range("AF4"), Range("AI4"), Range("AL4"), Range("AO4"), Range("AR4"), Range("AU4"), Range("AX4"), Range("BA4"), Range("BC4"), Range("BF4"), Range("BI4"), Range("BL4"), Range("BO4"), Range("BR4"), Range("BU4"), Range("BX4"), Range("CA4"))) Is Nothing Then Application.EnableEvents = False strAddress = Target.Address(0, 0) lCol = Range(strAddress).Column Range(Cells(6, lCol), Cells(1000, lCol - 1)).ClearContents Arr = GetData(Target.Value) If IsArray(Arr) Then Cells(6, lCol - 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr Application.EnableEvents = True End If End Sub

أضف سطر الإعلان عن المتغيرات في أول الموديول Dim LR As Long, LRQ As Long, Cell As Range وإن شاء الله يتم حل المشكلة تقبل تحياتي

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

ما زال الطلب غير مفهوم بالنسبة لي ... بالراحة عليا وخدني على أدي لأني مش متمكن أوي ... إنت قوووووووول بس ووضح وإن شاء الله تلاقي المساعدة من كل إخوانك تقبل تحياتي

أخي الكريم محمد اضغط من لوحة المفاتيح Alt + F11 هتدخل على محرر الأكواد من قائمة Insert هتلاقي الأمر Module انسخ الكود والصقه في الموديول احفظ الملف .. لما تظهر لك رسالة الحفظ بتكتب اسم الملف وتحدد مكانه وأهم شيء تخلي الامتداد Macro Enabled (نوع الحفظ من نفس النافذة) وأي استفسار ستجدنا بعون الله وتوفيقه تقبل تحياتي

أخي مصطفى لم أقهم المقصود بالإضافة ؟؟؟ هل الإضافة في ورقة عام أم في ورقة الحصص؟؟ جرب أن تضيف في ورقة عام بيانات جديدة وجرب الكود مرة أخرى باختيار رقم المعلم ...

أخي الحبيب أبو حنين غير المسار إلى البارتشن D أو أي بارتشن آخر Const ObscurePath = "C:\"

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

أخي وحبيبي مختار بارك الله فيك ملف رائع وجميل ولكن لاحظ ان المخرجات مرتبطة بالملف الأصلي .. روح على الشيت التالت في أي مصنتف من المخرجات تقبل تحياتي

بارك الله فيك أخي وحبيبي في الله سعيد بيرم كود رائع بحق ..تسلم الأيادي إليك أخي الكريم رضا راغب الملف المرفق فيه تطبيق كود أخونا الحبيب سعيد بيرم يتم الترحيل حسب الكود المرفق في الملف كل 5 ثواني (للتجربة فقط ..يمكنك تغيير الوقت المطلوب من الكود) Transfer Data Every 5 Seconds.rar

أخي الكريم أين الملف المرفق الأخير الخاص بك؟ الترقيم يعمل في الملف الأول الذي قمت بإرفاقه لك بشكل صحيح يرجى مراجعة الكود الأول مرة أخرى للتأكد تقبل تحياتي

أخي الكريم مصطفى محمود مصطفى إليك الملف المرفق الخاص بك .. والعمل بالأكواد بدون معادلات .. حيث أن معادلات الصفيف لا أحبذها كثيراً يوضع الكود التالي في موديول عادي Public Coll As New Collection Public Function RefreshCollection() As Collection Dim collDummy As New Collection, ArrIn, ArrHead, I As Long, J As Long, Str1 As String, V Set Coll = Nothing With Sheet1.Range("C46").CurrentRegion ArrIn = .Value ArrHead = .Resize(1).Offset(-44).Value For J = 3 To UBound(ArrIn, 2) Step 2 For I = 2 To UBound(ArrIn, 1) If Len(ArrIn(I, J)) Then On Error Resume Next Str1 = CStr(ArrIn(I, J)) V = Coll(Str1) If Err.Number <> 0 Then Set collDummy = Nothing Coll.Add Key:=Str1, Item:=collDummy End If On Error GoTo 0 Coll(Str1).Add Array(ArrIn(I, J), ArrIn(I, J - 1), ArrHead(1, J - 1)) End If Next I Next J End With Set RefreshCollection = Coll End Function Public Function GetData(Param As String) Dim ArrOut, I As Long, V1, V2 If Coll.Count = 0 Then Set Coll = RefreshCollection() On Error Resume Next Set V1 = Coll(Param) If Err.Number = 0 Then ReDim ArrOut(1 To V1.Count, 1 To 2) For Each V2 In V1 I = I + 1 ArrOut(I, 1) = V2(1) ArrOut(I, 2) = V2(2) Next V2 GetData = ArrOut End If On Error GoTo 0 End Function ويوضع الكود التالي في حدث ورقة العمل المسماة حصص المعلمين Private Sub Worksheet_Activate() Set Coll = RefreshCollection() End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Arr Application.EnableEvents = False Select Case Target.Address(0, 0) Case "H4" Range("G6:H1000").ClearContents Arr = GetData(Target.Value) If IsArray(Arr) Then Range("G6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr Case "K4" Range("J6:K1000").ClearContents Arr = GetData(Target.Value) If IsArray(Arr) Then Range("J6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr End Select Application.EnableEvents = True End Sub غير رقم المعلم في الخلايا الصفراء وفقط تقبل تحياتي Grab Data By Teacher's ID YasserKhalil.rar

أخي الكريم جرب الملف المرفق التالي ** الكود مقسم إلى كود يوضع في موديول عادي Public Arr, ArrOut Sub RefreshArray() Dim WS As Worksheet, ArrTemp, I As Long, P As Long ReDim Arr(1, 0) For Each WS In Sheets If WS.Name <> "البحث" And WS.Name <> "تصفية البيانات المكررة " And WS.Name <> "بيانات ثانوية" Then If WS.Cells(Rows.Count, "G").End(xlUp).Row > 1 Then ArrTemp = WS.Range("A1").CurrentRegion.Columns("G").Value I = UBound(Arr, 2) + UBound(ArrTemp, 1) ReDim Preserve Arr(1, I) For I = 2 To UBound(ArrTemp, 1) If Len(ArrTemp(I, 1)) Then Arr(0, P) = ArrTemp(I, 1) Arr(1, P) = WS.Name & "/" & I P = P + 1 End If Next I End If End If Next WS ReDim Preserve Arr(1, P - 1) End Sub Sub GetSearchResult(Param As String) Dim LastRow As Long, I As Long, P As Long If Not IsArray(Arr) Then RefreshArray ReDim ArrOut(1, UBound(Arr, 2)) With Sheets("البحث") LastRow = Application.Max(.Cells(.Rows.Count, "E").End(xlUp).Row, 3) .Range("E3:E" & LastRow).ClearContents P = 0 For I = LBound(Arr, 2) To UBound(Arr, 2) If InStr(1, Arr(0, I), Param, vbTextCompare) Then ArrOut(0, P) = Arr(0, I) ArrOut(1, P) = Arr(1, I) P = P + 1 End If Next I If P > 0 And Param <> "" Then ReDim Preserve ArrOut(1, P - 1) .Range("E3").Resize(UBound(ArrOut, 2) + 1, 1).Value = Application.Transpose(ArrOut) Else .Range("B2:B26,D2:D26").ClearContents End If End With End Sub Sub RefreshList(Param As Long) Dim Arr, ArrOut1(1 To 25, 1 To 1), ArrOut2(1 To 25, 1 To 1), I As Long With Sheets("البحث") .Range("B2:B26,D2:D26").ClearContents On Error Resume Next Arr = Sheets(Split(ArrOut(1, Param - 3), "/")(0)).Rows(Val(Split(ArrOut(1, Param - 3), "/")(1))).Resize(, 56).Value If Err.Number <> 0 Then Exit Sub On Error GoTo 0 ArrOut1(1, 1) = Arr(1, 9) For I = 2 To 25 ArrOut1(I, 1) = Arr(1, I + 5) Next I For I = 1 To 25 ArrOut2(I, 1) = Arr(1, I + 31) Next I .Range("B2").Resize(UBound(ArrOut1, 1), UBound(ArrOut1, 2)).Value = ArrOut1 .Range("D2").Resize(UBound(ArrOut2, 1), UBound(ArrOut2, 2)).Value = ArrOut2 End With End Sub والجزء الثاني يوضع في حدث ورقة العمل المسماة "البحث" Private Sub TextBox1_Change() GetSearchResult TextBox1.Text End Sub Private Sub Worksheet_Activate() RefreshArray End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Columns("E")) Is Nothing Then If Target.Row >= 3 And Target.Count = 1 Then If Len(Target.Value) Then RefreshList Target.Row End If End If End Sub أرجو أن يكون المطلوب ويعالج مشكلة البطء لديك إن شاء الله تقبل تحياتي Textbox Search All Sheets YasserKhalil.rar