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

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

أخي زوهير تعلم جيداً أنه عندما لا توجد استجابة من الأعضاء فهذا معناه أن الفكرة لم تتضح ولم توضح أين معيار البحث كما سألك الأخ عبد العزيز ...؟ أين هو مربع النص الذي يتم البحث من خلاله ؟ وهل البحث عن عمود محدد كعمود الأسماء أم ماذا ؟؟ أعتقد أنه يجب أن تضرب مثال ليتضح المقال

أخي الكريم عبد الواحد يرجى تغيير اسم الظهور للغة العربية هل تم حل المشكلة تماماً أم أنه ما زالت المشكلة عالقة؟

كل عام وأنت بخير أخي خالد يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى تقبل تحياتي

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

جرب الملف التالي .. يتم مسح البيانات القديمة أولاً قبل ترحيل البيانات الجديدة ثم يتم ترحيل البيانات الجديدة من ملفات المجلد الأول إلى ملفات المجلد الثاني Officena.rar

طلبك أخي الكريم سهل للغاية يمكنك العمل على حدث تغير ورقة العمل ... بفرض أن لديك الماكرو التالي في موديول Sub MyMacro() MsgBox "Hello Officena" End Sub قم بعمل كليك يمين على اسم ورقة العمل ثم View Code ثم ضع الكود التالي في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$C$2" Then Call MyMacro End If End Sub عند حدوث تغيير في الخلية C2 سيتم تنفيذ الماكرو المسمى MyMacro

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

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

وعليكم السلام كل عام وأنت بخير أخي الكريم أبو زيد جرب الملف التالي ولا تنسى أن تحدد أفضل إجابة إذا تم الأمر على خير Transfer Data To Closed Workbook.rar

أخي الكريم أبو سليمان جرب هذا التعديل Sub AboSoliman() Dim ArrFiles, Cell As Range, I As Long, E As Long, str1 As String Dim strFolderSource As String, strFolderTarget As String, wbSource As Workbook, wbTarget As Workbook, wsSource As Worksheet, wsTarget As Worksheet 'اسم المجلد المصدر الي يتم ترحيل البيانات منه strFolderSource = "مجلد رقم 1" 'اسم المجلد الهدف المراد ترحيل البيانات إليه strFolderTarget = "مجلد رقم 2" Application.ScreenUpdating = False ReDim ArrFiles(1 To 1000): I = 0 Do If Len(str1) = 0 Then str1 = Dir(ThisWorkbook.Path & "\" & strFolderSource & "\*.xls*") Else str1 = Dir I = I + 1: ArrFiles(I) = str1 Loop Until Len(str1) = 0 If I = 1 Then Exit Sub Else ReDim Preserve ArrFiles(1 To I - 1) For I = 1 To UBound(ArrFiles) If Len(Dir(ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I))) = 0 Then FileCopy ThisWorkbook.Path & "\" & strFolderSource & "\" & ArrFiles(I), ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) Else Name ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) As ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I) Set wbSource = Workbooks.Open(ThisWorkbook.Path & "\" & strFolderSource & "\" & ArrFiles(I)) Set wbTarget = Workbooks.Open(ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I)) For Each wsSource In wbSource.Worksheets On Error Resume Next Set wsTarget = wbTarget.Worksheets(wsSource.Name) E = Err.Number On Error GoTo 0 If E <> 0 Then wbTarget.Worksheets.Add after:=wbTarget.Worksheets(wbTarget.Worksheets.Count) Set wsTarget = wbTarget.Worksheets(wbTarget.Worksheets.Count) wsTarget.Name = wsSource.Name End If With wsTarget .Range("A1:L1000").ClearContents Set Cell = .Range("A1") If (Cell.Row = 2) And (Application.WorksheetFunction.CountA(.Rows(1)) = 0) Then Set Cell = Cell.Offset(-1) End With wsSource.UsedRange.Copy Cell.PasteSpecial xlPasteValues Next wsSource wbSource.Close SaveChanges:=False wbTarget.Close SaveChanges:=True Name ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I) As ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) End If Next I Application.ScreenUpdating = True End Sub

الاخ الكريم عبد الواحد لقد أشار إليك الأخ الغالي عبد العزيز إلى الخطأ أو المشكلة .. هل قمت بتطبيق ما قاله عموماً جرب الملف التالي .. الملف يعمل بشكل جيد معي إذا كان هناك رسالة خطأ لا تنقر End بل انقر كلمة Debug وشوف السطر الملون باللون الأصفر وقلنا عليه لربما نستطيع أن نفيدك MAYAM 2.rar

الحمد لله أن تم 50% على الأقل ميبقاش الموضوع مفيش مشاركة فيه عايز أفهم ... بصرف النظر عن وضع مجلد جديد مكان الأول أو لا .. هل عملية الترحيل بشكل عام تتم فيتم مسح البيانات القديمة في المجلد الثاني أم ماذا ؟ لأنك لما ضربت مثال بطلاب الصف الثاني قلت دول ياحرااااااام محجوزين .. معنى الكلام إن البيانات تفضل زي ما هي وتضاف إليها البيانات الجديدة ؟؟؟؟!! فسؤالي : هل يتم مسح البيانات القديمة مع عملية الترحيل الجديدة؟

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

الاخ الكريم ممدوح يبدو أنك لم تستجب لطلبي ... لا غيرت اسم الظهور للغة العربية ولا أرفقت النتائج المتوقعة كما طلبت منك عموماً إليك هذا الكود عله يفي بالغرض يتم ترتيب الطلاب على أساس الدرجة فإذا تساوى الطلاب في الدرجة يتم الاحتساب على أساس تاريخ الميلاد فإذا تساوى الطلاب في الدرجة وتاريخ الميلاد يكتب كلمة مكرر ... Sub TopTenYasserKhalil() Dim Cell As Range, shTemp As Worksheet, ArrRanks ArrRanks = Array("الأول", "الثاني", "الثالث", "الرابع", "الخامس", "السادس", "السابع", "الثامن", "التاسع", "العاشر") Application.ScreenUpdating = False Set shTemp = Sheets.Add With Sheets("الرصد") Intersect(Union(.Columns("E"), .Columns("G"), .Columns("H"), .Columns("DQ")), .Rows("12:" & .UsedRange.Rows.Count)).Copy End With With shTemp.Range("A2") .PasteSpecial xlPasteValues .CurrentRegion.Sort Key1:=.Columns("D"), Order1:=xlDescending, _ Key2:=.Columns("C"), Order2:=xlAscending, _ Header:=xlNo With .Parent.Range("E2:E11") For Each Cell In .Cells With Cell If (.Offset(0, -1).Value = .Offset(-1, -1).Value) And (.Offset(0, -2).Value = .Offset(-1, -2).Value) Then .Value = .Offset(-1).Value Else .Value = .Offset(-1).Value + 1 End If End With Next Cell For Each Cell In .Cells With Cell .Value = ArrRanks(.Value - 1) If .Value = .Offset(-1).Value Then .Value = .Value & " مكرر" End With Next Cell End With With .Parent .Columns("C").Delete xlShiftToLeft .Range("A2:D11").Copy Sheets("أوائل التيرم الأول ").Range("G11").PasteSpecial (xlPasteValues) End With End With Application.DisplayAlerts = False shTemp.Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub كل عام وأنت بخير :gift2: كنترول ممدوح للمرحلة الإعدادية .rar

لو فهمت طلبك جرب تضع هذا السطر في الأول UserForm1.Show أي أن هذا السطر يسبق السطر الذي يقوم بتغيير لغة الإدخال

أخي الكريم أبو سليمان كل عام وأنت بخير إليك الكود الحلاونجي التالي عله يفي بالغرض .. يتم الترحيل من كل الملفات الموجود في المجلد الأول إلى كل الملفات بنفس الاسم في المجلد الثاني تم إنشاء مصنف باسم "الحلوى" بجانب المجلدين لتنفيذ مهمة الحلوى إن شاء الله يفي بالغرض Sub AboSoliman() Dim ArrFiles, Cell As Range, I As Long, E As Long, str1 As String Dim strFolderSource As String, strFolderTarget As String, wbSource As Workbook, wbTarget As Workbook, wsSource As Worksheet, wsTarget As Worksheet 'اسم المجلد المصدر الي يتم ترحيل البيانات منه strFolderSource = "مجلد رقم 1" 'اسم المجلد الهدف المراد ترحيل البيانات إليه strFolderTarget = "مجلد رقم 2" Application.ScreenUpdating = False ReDim ArrFiles(1 To 1000): I = 0 Do If Len(str1) = 0 Then str1 = Dir(ThisWorkbook.Path & "\" & strFolderSource & "\*.xls*") Else str1 = Dir I = I + 1: ArrFiles(I) = str1 Loop Until Len(str1) = 0 If I = 1 Then Exit Sub Else ReDim Preserve ArrFiles(1 To I - 1) For I = 1 To UBound(ArrFiles) If Len(Dir(ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I))) = 0 Then FileCopy ThisWorkbook.Path & "\" & strFolderSource & "\" & ArrFiles(I), ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) Else Name ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) As ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I) Set wbSource = Workbooks.Open(ThisWorkbook.Path & "\" & strFolderSource & "\" & ArrFiles(I)) Set wbTarget = Workbooks.Open(ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I)) For Each wsSource In wbSource.Worksheets On Error Resume Next Set wsTarget = wbTarget.Worksheets(wsSource.Name) E = Err.Number On Error GoTo 0 If E <> 0 Then wbTarget.Worksheets.Add after:=wbTarget.Worksheets(wbTarget.Worksheets.Count) Set wsTarget = wbTarget.Worksheets(wbTarget.Worksheets.Count) wsTarget.Name = wsSource.Name End If With wsTarget Set Cell = .UsedRange.Offset(.UsedRange.Rows.Count).Resize(1, 1) If (Cell.Row = 2) And (Application.WorksheetFunction.CountA(.Rows(1)) = 0) Then Set Cell = Cell.Offset(-1) End With wsSource.UsedRange.Copy Cell.PasteSpecial xlPasteValues Next wsSource wbSource.Close SaveChanges:=False wbTarget.Close SaveChanges:=True Name ThisWorkbook.Path & "\" & strFolderTarget & "\Temp_" & ArrFiles(I) As ThisWorkbook.Path & "\" & strFolderTarget & "\" & ArrFiles(I) End If Next I Application.ScreenUpdating = True End Sub تقبل الله منا ومنكم وكل عام وأنت بخير :fff: أوفيسنا.rar

أخي الحبيب محمد الريفي ... تقبل الله منا ومنكم وكل عام وأنت بخير بالنسبة للحل المقدم يقوم باستخراج القيم من عمود واحد فقط وبدون ترتيب والمطلوب على ما يبدو لي : استخراج كل القيم من الثلاثة أعمدة بدون فراغات ثم ترتيب البيانات حسب العمود الثالث في النتائج المستخرجة

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

الأخ الكريم محمود بك كل عام وأنت بخير وكل عام وكل أعضاء المنتدى والأمة الإسلامية بأسرها بخير جزيت خيراً على المبادرة تقبل الله منا ومنكم ومن سائر المسلمين

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

تفضل أخي المنور نور أنور Rasd2015.rar

جرب الكود بهذا الشكل عله يفي بالغرض Sub Test() Dim I As Long, J As Long, WS As Worksheet Set WS = Sheets("رصد 2015") Application.ScreenUpdating = False With WS For I = 15 To .Cells(Rows.Count, 1).End(xlUp).Row Step 2 For J = 11 To 22 If .Cells(I, J) < .Cells(I - 1, J) And Not IsEmpty(.Cells(I - 1, J)) Then .Cells(I, J) = .Cells(I - 1, J) Next J Next I End With Application.ScreenUpdating = True End Sub

الأخ الكريم نور الملف غير منطقي بعض الشيء الرقمين لطالبين مخلتفين !! أو يمكن أكون فهمت غلط وضح ما هي الصفوف التي تخص كل طالب حيث أن الأمر ملتبس عليا بعض الشيء

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