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

وكل عام وأنت بخير أخي الكريم أحمد الحمد لله أن تم المطلوب على خير تقبل تحياتي

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

الأخ الكريم أبو حنين كل عام وأنت بخير .. كنت أفضل أن تطرح موضوع مستقل ... ولكن ولا يهمك تفضل جرب الكود التالي Sub TransferDatabyDay() Dim WS As Worksheet Dim lDay As String, LR As Long Set WS = Sheets("واجهة البيع") lDay = Day(Now) If blnWorksheetExists(lDay) = False Then Sheets.Add After:=Sheets(Sheets.Count) With Sheets("Temp") .Visible = True .Cells.Copy ActiveSheet.Range("A1") .Visible = False End With ActiveSheet.Name = lDay End If With Sheets(lDay) LR = .Cells(65, "C").End(xlUp).Row + 1 .Range("C" & LR) = WS.Range("H11").Value .Range("D" & LR) = WS.Range("J11").Value End With MsgBox "تمت عملية الترحيل", vbInformation End Sub Function blnWorksheetExists(strWorksheet As String) As Boolean On Error Resume Next blnWorksheetExists = Not (ThisWorkbook.Worksheets(strWorksheet) Is Nothing) On Error GoTo 0 End Function تم إنشاء ورقة عمل باسم Temp كنموذج يتم النسخ منه في حالة عدم وجود ورقة عمل Transfer To Specific Sheet & Create If Not Found.rar

جرب تغير هذا الجزء Step -1 من -2 إلى -1

أخي الحبيب أبو سليمان لابد أن تعلم جيداً أن فهم المطلوب - حتى لو كان صعباً - يمثل 90% من الحل لـــــــــــــــــــــــــــــذا يجب دائماً وأبداً التوضيح التاااااااااااااااااااااااااام والجيد للمطلوب وإلا لن تجد استجابة مهما كثر رفع الموضوع ومهما تعددت الردود ... إذ أنه لا يعقل أن يساهم بالمساعدة شخص لا يفهم المطلوب .. أمر آخر مهم جداً وهو المسميات .. أنت تذكر كلمة مجلد في المشاركة رقم 1 .. صحيح !! هل المقصود بالمجلد المجلد (الذي نعرفه ذو اللون الأصفر ...) ؟؟ لا أعتقد .. أعتقد أنك تقصد المصنف (Workbook) ..أياً كان يجب التأكد من صحة المسميات عند شرح المطلوب .. أمر آخر .. ما هو المصنف في المرفقات المطلوب العمل عليه ؟؟؟؟ يجب أن يكون مصنف واحد وليس اثنان ولو كان اثنان يرجى شرح آلية العمل أمر آخر : هل تقصد من الموضوع عملية ترحيل للبيانات من الملفات الموجودة في المجلد رقم 1 إلى المجلد رقم 2 إلى نفس الملفات التي تحمل نفس الاسم ؟ أين تريد وضع الأكواد .. في أي مصنف ؟؟ أم أنه يتم عمل مصنف آخر يقوم بالمهمة ؟؟ أسئلة كثيرة جداً تسهل الوصول لحل .. إذا توافرت العناصر وفهم المطلوب بشكل جيد فبالتأكيد ستجد المساعدة بإذن الله تقبل تحياتي وكل عام وأنت بخير

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

ارفق مثال ليتضح المقال

أخي خالد ركز .. قيمة الخلية تساوي كام ؟ 11 .. يعني الحلقة التكرارية هتبدأ من 14 إلى 11 إزاي .. المعادلة في الخلية B4 اللي هي الناتج بتاعها 11 زود عليها 13عشان تضبط معاك رقم الصف ليصبح رقم الصف كما في الملف المرفق 24 في الحالة دي المعادلة هتكون بهذا الشكل في الخلية B4 =COUNT(Serial)+13 فتتم الحلقة التكرارية من الصف الـ 14 إلى الصف 24 تقبل تحياتي

صراحة الملف دوخني ولم أستطع العمل عليه لعدم تنسيق الملف بشكل جيد .. ينصح بإزالة البيانات في أسفل الأعمدة حتى يمكنك تحديد آخر صف به بيانات في ورقة العمل المسماة Main يوجد حرف الـ غ في الصف 121 .. مما يؤثر على جلب آخر صف به بيانات .. بالنسبة لشرح الجزئية التي تريدها .. عبارة عن حلقة تكرارية من الصف رقم 14 إلى آخر صف به بيانات .. وأنصح هنا أن تحدد آخر صف بنفسك لأن البيانات متداخلة في نفس العمود ..يعني استبدل هذا الجزء .Cells(Rows.Count, 1).End(3).Row برقم 24 ليمثل آخر صف هذا السطر .Cells(I, RngColA) < RngA لو الدرجة في عمود "الاختبار" أقل من الدرجة 1 (الدرجة الصغرى للاختبار) هذا الجزء .Cells(I, RngColB) < RngB لو الدرجة في عمود "درجة المادة" أقل من الدرجة 2 (الدرجة الصغرى لدرجة المادة) يتم ترحيل البيانات لأنه يعد راسب .. باختصار اضبط الملف لتتمكن من استخدام الكود بشكل سليم تقبل تحياتي

الأخ مصر 2015 ... ربنا يصلح مصر في 2015 يرجى تغيير اسم الظهور للغة العربية وباسم مناسب إذا أمكن (دا إذا مكانش يضايقك طبعاً) بالنسبة لطلبك سهل للغاية بفرض أن العمود الأول والثاني يحتوي قيم وتريد جمع القيم من العمودين في العمود الثالث C قم بتحديد العمود بالكامل .... من خلال النقر مرة واحدة على رأس العمود (انقر عليه هيطب سااااكت علطول ..) هتلاقي العمود كلها متحدد روح لشريط المعادلات وضع المعادلة فيه =SUM(A1:B1) واضغط Ctrl + Enter مش إنتر بس ... سيتم تنفيذ المعادلة على كامل العمود .. ملحوظة : يرجى عدم تطبيق المعادلة على كامل العمود .. لأن ذلك سيسبب ثقل في الملف حيث أن عدد الصفوف في ورقة العمل كبير جداً .. يكفي أن تكتب القيم مثلاً في العمودين ثم تسحب المعادلة مرة واحدة إلى نهاية النطاق الذي تعمل عليه أو تضغط دبل كليك على مقبض السحب .. تقبل تحياتي

تفضل الملف المرفق وحاول أن تطبق بنفسك لتستفيد حسابات محل.rar

تفضل أخي الملف التالي Extract Values Skipping Blanks & Sort YasserKhalil.rar

أخي الكريم وجدي جرب المعادلة التالية =INDIRECT("'"&DAY(NOW())&"'!D65") وللاستفادة ولفهم عمل الدالة قم بزيارة هذا الموضوع المميز للأخ خالد الرشيدي شرح الدالة INDIRECT

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

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

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

أخي الكريم سامي إذا أردت الحفاظ على تنسيق العمود بحيث يظل تنسيقه كنص وفي نفس الوقت تريد التخلص من هذا الشكل .. اتبع الآتي حدد العمود C ثم اذهب للتبويب Data ثم اختر الأمر Text to Columns ثم اضغط Next مرتين ثم اختر الاختيار Text ثم أخيراً انقر على كلمة Finish تقبل الله منا ومنكم وكل عام وأنتم بخير

أضف السطر التالي بعد سطر رسالة "تمت عملية الترحيل" Range("H11:K12").ClearContents وحاول أن تبتعد قدر الإمكان عن دمج الخلايا لأنه يسبب مشاكل مع الكود

أخي الكريم وجدي الحاج علي إليك الكود التالي عله يفي بالغرض Sub TransferDatabyDay() Dim lDay As String, LR As Long lDay = Day(Now) On Error GoTo YK With Sheets(lDay) LR = .Cells(65, "C").End(xlUp).Row + 1 .Range("C" & LR) = Range("H11").Value .Range("D" & LR) = Range("J11").Value End With MsgBox "تمت عملية الترحيل", vbInformation Exit Sub YK: MsgBox "لم تتم عملية الترحيل ، قد يكون السبب عدم وجود ورقة العمل", vbCritical End Sub في حالة عدم وجود ورقة العمل لليوم الحالي يتم إظهار رسالة تفيد بذلك لا تنسى تحديد أفضل إجابة وكذلك اضغط على "أعجبني هذا" (يعني قفل الموضوع لو تمت الإجابة عليه بشكل يرضيك) تقبل الله منا ومنكم حسابات محل.rar

الأخ الفاضل مهند القانوع جرب الكود بهذا الشكل Sub ExtractAndSort() Dim lRow As Long Dim J As Long With ThisWorkbook.Worksheets("2") .Columns("K:M").ClearContents For lRow = 1 To 100 If Len(.Cells(lRow, 1)) Then J = J + 1 .Cells(J, 11).Resize(, 3).Value = .Cells(lRow, 1).Resize(, 3).Value End If Next lRow End With With Range("K1:M1").CurrentRegion .Sort Key1:=.Cells(1, 3), Order1:=xlAscending End With End Sub

الأخ الكريم يرجى تغيير اسم الظهور للغة العربية بعد إذن أخي الحبيب سليم وإثراءً للموضوع إليك حل بالأكواد عله يفي بالغرض .. تم الفرز على أساس العمود M Sub ExtractUniqueAndSort() Dim lRow As Long Dim Element As Variant Dim Dict As Object Dim J As Long Set Dict = CreateObject("Scripting.Dictionary") With ThisWorkbook.Worksheets("2") .Columns("K:M").ClearContents For lRow = 1 To 100 If Len(.Cells(lRow, 1)) Then If Not Dict.exists(.Cells(lRow, 1).Value) Then Dict.Add .Cells(lRow, 1).Value, 1 J = J + 1 .Cells(J, 11).Resize(, 3).Value = .Cells(lRow, 1).Resize(, 3).Value '*** End If End If Next lRow Set Dict = Nothing End With Set Dict = Nothing With Range("K1:M1").CurrentRegion .Sort Key1:=.Cells(1, 3), Order1:=xlAscending End With End Sub تقبل تحياتي Unique Values & Sort YasserKhalil.rar

أنا أعمل على أوفيس 2013 ويعمل بشكل جيد عندي جرب الملف المرفق الذي قدمه لك الأخ الحبيب الغالي الغائب عن العيون محمد أبو عباس في المشاركة رقم 19 http://www.officena.net/ib/index.php?showtopic=62661#entry406484 جربت الملف ويعمل في ورقتي العمل بشكل ممتاز جرب تنصب أوفيس 2013 (خليك مع الجديد .. عشان تستفيد)

ما هي نسخة الأوفيس التي تعمل عليها؟

أخي الكريم أبو زيد هل تم عمل المطلوب بشكل جيد الآن أم لا؟

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