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

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

السلام عليكم جرب التعديل التالي عله يفي بالغرض Sub Test() Dim ws As Worksheet Dim sh As Worksheet Dim r As Long Dim m As Long Set ws = Sheets("تسجيل الدرجات") Set sh = Sheets("دور ثاني") m = 11 Application.ScreenUpdating = False For r = 11 To 307 Step 2 sh.Range("E" & r & ":CT" & r).ClearContents Next r For r = 8 To 306 If ws.Cells(r, 3) = "راسب" Then sh.Range("E" & m).Resize(1, 95).Value = ws.Range("D" & r).Resize(1, 95).Value m = m + 2 End If Next r Application.ScreenUpdating = True MsgBox ("الحمد لله تـــم الترحيل ") End Sub

ليس هذا الموضع الذي قصدته .. انظر بالأعلى قليلاً ستجد جملة End With أخرى قبلها ...

جرب نقل الأسطر التالية إلى قبل جملة End With .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value

وعليكم السلام بشكل افتراضي تظهر رسالة لك في بداية فتحك للملف تطلب منك تحديث الروابط ... إذا كانت تظهر لك فلا يوجد مشكلة

السلام عليكم جرب الكود التالي .. سيقوم بإغلاق المصنفات المفتوحة بدون حفظها Sub CloseAllOpenWorkbooksWithoutSave() Dim Wb As Workbook With Application .ScreenUpdating = False .DisplayAlerts = False For Each Wb In Workbooks With Wb .Close False End With Next Wb .ScreenUpdating = True .DisplayAlerts = True .Quit End With End Sub

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

السلام عليكم جرب الكود التالي Sub SaveCloseAllOpenWorkbooks() Dim Wb As Workbook With Application .ScreenUpdating = False For Each Wb In Workbooks With Wb If Not Wb.ReadOnly Then .Save End If If .Name <> ThisWorkbook.Name Then .Close End If End With Next Wb .ScreenUpdating = True .Quit End With End Sub

بارك الله فيك أخي العزيز محمود وكل عام وأنت بخير والحمد لله الذي بنعمته تتم الصالحات

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

وعليكم السلام وكل عام وأنت بخير أخي الكريم الملف المرفق يجب أن يكون معبر عن الملف الأصلي تماماً لكي يكون الكود مناسب للموضوع .. أمر آخر يرجى عدم اقتباس الأكواد في الردود لكي لا يطول الموضوع بدون داعي جرب الكود التالي عله يفي بالغرض إن شاء الله Option Explicit Sub ImportDataFromClosedWBs_YasserKhalil() Dim strFolder As String Dim strFile As String Dim wbk As Workbook Dim sh As Worksheet Dim lr As Long Dim i As Long With Application .ScreenUpdating = False .Calculation = xlManual .DisplayAlerts = False .AskToUpdateLinks = False End With strFolder = ThisWorkbook.Path & "\الفواتير\" strFile = Dir(strFolder & "*.xls*") Do While strFile <> "" Set wbk = Workbooks.Open(strFolder & strFile) Set sh = wbk.Worksheets(1) With ThisWorkbook.Worksheets(1) i = 7 Do lr = IIf(.Cells(Rows.Count, 1).End(xlUp).Row < 3, 3, .Cells(Rows.Count, 1).End(xlUp).Row + 1) .Range("A" & lr).Resize(1, 6).Value = sh.Range("A" & i).Resize(1, 6).Value .Range("G" & lr).Resize(1, 2).Value = sh.Range("A2").Resize(1, 2).Value .Range("I" & lr).Value = sh.Range("F1").Value .Range("J" & lr).Value = sh.Range("F2").Value .Range("K" & lr).Value = sh.Range("F3").Value .Range("O" & lr).Value = sh.Range("B2").Value i = i + 1 Loop Until sh.Range("A" & i).Value = "" End With wbk.Close False strFile = Dir Loop With Application .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub

السلام عليكم جرب الكود التالي .. بعد تنفيذ الكود لا تلمس الماوس أو لوحة المفاتيح إلى أن ينتهي الكود من عمله Sub Test() Dim cel As Range Range("B1").Select Application.ScreenUpdating = False For Each cel In Range("B1:B1000") SendKeys "{F2}{Enter}" Next cel Application.ScreenUpdating = True End Sub

السلام عليكم جرب وضع السطر التالي في موديول عادي Public o As Variant ثم ضع الكود التالي في حدث المصنف Private Sub Workbook_Activate() Range("N1").Value = "" End Sub Private Sub Workbook_Open() o = Sheet1.Range("C7").Value End Sub ثم ضع الكود التالي في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) If Range("C7").Value <> o Then Application.EnableEvents = False Range("D7").Value = Range("D7").Value + 1 Application.EnableEvents = True End If o = Range("C7").Value End Sub

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

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

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

بارك الله فيك أخي الكريم سيد والحمد لله أن تم المطلوب على خير ، والحمد لله الذي بنعمته تتم الصالحات تقبل وافر تقديري واحترامي وكل عام وأنت بخير

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

No Comment Is Good Comment Regards

أترفع الموضوع قبل رفع الآدان بوقتٍ قليل ... كل عام وأنت بخير أخي الحبيب أبو عبد الرحمن ، وننتظر مشاركات الأخوة الكرام بالموضوع

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

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

وعليكم السلام أخي الكريم في الحقيقة لا أحب تغيير هيكلة الملفات المرفقة حيث أن ذلك يلزمه تغير في الموضوع ... في الملف الجديد لاحظت أنك قمت بتحويل النطاقات إلى جداول في أوراق العمل "شيكات البنك العربي" و "شيكات البنك الاهلي" بينما ورقة العمل "شيكات البنك الفرنسي" لم يتم تحويلها لجدول .... انظر في الأوراق المذكورة في نهايتها ستجد بيانات في آخر الجدول وليس داخل الجدول .. لذا أولاً يجب ضبط الملف ومسح البيانات الموجودة في آخر الأوراق والتي توجد خارج نطاق الجدول .. وأيضاً قم بتحويل النطاق في آخر ورقة "شيكات البنك الفرنسي" إلى جدول لتكون الأوراق بنفس الهيكل ... ثم قم بحذف الأكواد التي لديك كلها واستخدم كود واحد فقط الذي سأدرجه لك الآن ... وها هو الكود .. وبعد وضعه في موديول قم بربط الأزرار الموجودة في الأوراق المعنية بهذا الكود فقط ... لا تقم بنسخ الكود ثلاثة مرات كما هو مرفق في ملفك بل استخدم الكود مرة واحدة فقط للثلاثة أوراق Option Explicit Sub TransferBankDetails() Dim ws As Worksheet Dim sh As Worksheet Dim lr As Long Application.ScreenUpdating = False Set ws = ActiveSheet Set sh = ThisWorkbook.Sheets("شيكات " & ActiveSheet.Name) If Left(ws.Name, 5) <> "البنك" Then Exit Sub lr = sh.Cells(LastTableRow(sh), 1).End(xlUp).Row + 1 sh.Cells(lr, 1).Value = ws.Range("B2").Value sh.Cells(lr, 2).Value = ws.Range("D7").Value sh.Cells(lr, 3).Value = ws.Range("A8").Value sh.Cells(lr, 5).Value = ws.Range("F10").Value Application.ScreenUpdating = True MsgBox "Done...", 64 End Sub Function LastTableRow(Optional ByVal TableSheet As Worksheet) As Long Dim Table As ListObject Dim LastRow As Long If TableSheet Is Nothing Then If ActiveSheet Is Nothing Then Exit Function Set TableSheet = ActiveSheet End If For Each Table In TableSheet.ListObjects If Table.DataBodyRange Is Nothing Then LastRow = WorksheetFunction.Max(Table.InsertRowRange.Row + 1, LastRow) Else LastRow = WorksheetFunction.Max(Table.ListRows(Table.ListRows.Count).Range.Row, LastRow) End If If Table.ShowTotals Then LastRow = LastRow + 1 Next Table LastTableRow = LastRow End Function

أخي الكريم محمود المشكلة في هيكلة الملف .. غير مريحة للعمل عليها في الحقيقة عموماً جرب الكود التالي عله يفي بالغرض Sub Test() Dim rng As Range Dim cel As Range Application.ScreenUpdating = False With ActiveSheet .Rows("12:131").Hidden = False If Not IsEmpty(.Range("D4")) And Not IsEmpty(.Range("H4")) Then For Each cel In .Range("B12:B55") If cel.Value = "النسبة 1" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("12:55").Hidden = True End If If .Range("D55") = "" Or .Range("D55") = 0 Then .Rows("54:55").Hidden = True Set rng = Nothing: Set cel = Nothing '=============================================================== If Not IsEmpty(.Range("D5")) And Not IsEmpty(.Range("H5")) Then For Each cel In .Range("B56:B99") If cel.Value = "النسبة 2" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("56:99").Hidden = True End If If .Range("D99") = "" Or .Range("D99") = 0 Then .Rows("98:99").Hidden = True Set rng = Nothing: Set cel = Nothing '=============================================================== If Not IsEmpty(.Range("D6")) And Not IsEmpty(.Range("H6")) Then For Each cel In .Range("B100:B131") If cel.Value = "النسبة 3" Then If cel.Offset(1) = "" Or cel.Offset(1) = 0 Then If rng Is Nothing Then Set rng = cel.Resize(4) Else Set rng = Union(cel.Resize(4), rng) End If End If End If Next cel If Not rng Is Nothing Then rng.EntireRow.Hidden = True End If Else .Rows("100:131").Hidden = True End If If .Range("D104") = "" Or .Range("D104") = 0 Then .Rows("100:108").Hidden = True If .Range("D131") = "" Or .Range("D131") = 0 Then .Rows("129:131").Hidden = True Set rng = Nothing: Set cel = Nothing End With Application.ScreenUpdating = True End Sub

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