ابو حمادة قام بنشر مايو 15, 2017 مشاركة قام بنشر مايو 15, 2017 مرفق ملف استدعاء بيانا.rar رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 16, 2017 الكاتب مشاركة قام بنشر مايو 16, 2017 12 ساعات مضت, ابو حمادة said: مرفق ملف استدعاء بيانا.rar صباح الخير لاساتذتى الكرام فيهكود تمام لاستدعاء البيانات جبته ووضعته في الملف بس بيجلب كل البيانات من صفحة البيانات الاساسيه محتاج تعديل عليه فقط بحيث يجلب بيانات الكشف ال اختاره فقط Sub Add() Dim Rng2 As Range Dim LR, LE As Long '=========================================================== Dim sh1 As Worksheet: Set sh1 = Sheets("بيانات اساسية") Dim sh2 As Worksheet: Set sh2 = Sheets("كشف") LE = sh1.Cells(Rows.Count, "Q").End(xlUp).Offset(1, 0).Row Set Rng2 = sh1.Range("Q6:BX" & LE) If Application.WorksheetFunction.CountA(sh2.Range("B6:B34")) = 29 Then 'MsgBox "لا يمكن استدعاء كل البيانات بسبب " If MsgBox("لا يمكن استدعاء كل البيانات بسبب كثرة البيانات عن حجم الورقة", vbMsgBoxRight, "تاكيد الحفظ ") = vbNo Then Exit Sub Exit Sub End If LR = sh2.Range("B35").End(xlUp).Row + 1 If LR < 6 Then LR = 6 '=========================================================== Application.ScreenUpdating = False '=========================================================== Rng2.Copy sh2.Range("B" & LR).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub يريت حد يساعدني في تعديله رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 16, 2017 الكاتب مشاركة قام بنشر مايو 16, 2017 8 ساعات مضت, ابو حمادة said: صباح الخير لاساتذتى الكرام فيهكود تمام لاستدعاء البيانات جبته ووضعته في الملف بس بيجلب كل البيانات من صفحة البيانات الاساسيه محتاج تعديل عليه فقط بحيث يجلب بيانات الكشف ال اختاره فقط Sub Add() Dim Rng2 As Range Dim LR, LE As Long '=========================================================== Dim sh1 As Worksheet: Set sh1 = Sheets("بيانات اساسية") Dim sh2 As Worksheet: Set sh2 = Sheets("كشف") LE = sh1.Cells(Rows.Count, "Q").End(xlUp).Offset(1, 0).Row Set Rng2 = sh1.Range("Q6:BX" & LE) If Application.WorksheetFunction.CountA(sh2.Range("B6:B34")) = 29 Then 'MsgBox "لا يمكن استدعاء كل البيانات بسبب " If MsgBox("لا يمكن استدعاء كل البيانات بسبب كثرة البيانات عن حجم الورقة", vbMsgBoxRight, "تاكيد الحفظ ") = vbNo Then Exit Sub Exit Sub End If LR = sh2.Range("B35").End(xlUp).Row + 1 If LR < 6 Then LR = 6 '=========================================================== Application.ScreenUpdating = False '=========================================================== Rng2.Copy sh2.Range("B" & LR).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub يريت حد يساعدني في تعديله ايه الموضوع صعب اوى ولا ايه مش شايف اي رد نهائي رابط هذا التعليق شارك More sharing options...
خالد الرشيدى قام بنشر مايو 16, 2017 مشاركة قام بنشر مايو 16, 2017 السلام عليكم اى عمود بصفحه البيانات الاساسية يحدد اسم الكشف ؟؟؟؟؟؟؟؟؟ 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 16, 2017 الكاتب مشاركة قام بنشر مايو 16, 2017 4 دقائق مضت, خالد الرشيدى said: السلام عليكم اى عمود بصفحه البيانات الاساسية يحدد اسم الكشف ؟؟؟؟؟؟؟؟؟ اي عمود مش هاتفرق وانا اعدل عليه عادي وليكن مثلا في العمودي ( B ) رابط هذا التعليق شارك More sharing options...
خالد الرشيدى قام بنشر مايو 16, 2017 مشاركة قام بنشر مايو 16, 2017 (معدل) اخي الكريم على الرغم من ان هناك امور غير واضحه .. مثل لو عددهم 29 لا يتم الترحيل .. وايضاً انت بتجيب رقم الصف الفارغ بشيت الكشف بدءاً من B35 صعوداً لاعلى وبذلك تجاهلت باقي الصفوف التى هي اسفل منها .. ومع ذلك اليك الطريقة وعليك التعديل بما يناسبك فيما يتعلق بالجزئيتين السابقتين استدعاء بيانا_2.rar ( تم الغاء دمج الخلايا B3:B5 لانه من شأنه ان يفسد عمل الكود .. يمكنك ان تدمج B3:B4 ولكن ضع اى قيمه في B5 ولو بشكل مخفي بحيث تكون القيمة بلون ارضيه الخلية ) تقبل خالص تحياتى تم تعديل مايو 16, 2017 بواسطه خالد الرشيدى 1 رابط هذا التعليق شارك More sharing options...
خالد الرشيدى قام بنشر مايو 16, 2017 مشاركة قام بنشر مايو 16, 2017 (معدل) 2 ساعات مضت, ابو حمادة said: ايه الموضوع صعب اوى ولا ايه مش شايف اي رد نهائي اخى الكريم لابد من التماس العذر لإخوانك .. الكل له اعماله ومشاغله .. والمساهمة فى الموقع مجانيه ولا يوجد من هو مضطر لذلك .. واحيانا عدم وضوح الطلب هو سبب تأخر الرد .. تقبل مرورى وتحياتى تم تعديل مايو 16, 2017 بواسطه خالد الرشيدى 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 17, 2017 الكاتب مشاركة قام بنشر مايو 17, 2017 13 ساعات مضت, خالد الرشيدى said: اخي الكريم على الرغم من ان هناك امور غير واضحه .. مثل لو عددهم 29 لا يتم الترحيل .. وايضاً انت بتجيب رقم الصف الفارغ بشيت الكشف بدءاً من B35 صعوداً لاعلى وبذلك تجاهلت باقي الصفوف التى هي اسفل منها .. ومع ذلك اليك الطريقة وعليك التعديل بما يناسبك فيما يتعلق بالجزئيتين السابقتين استدعاء بيانا_2.rar ( تم الغاء دمج الخلايا B3:B5 لانه من شأنه ان يفسد عمل الكود .. يمكنك ان تدمج B3:B4 ولكن ضع اى قيمه في B5 ولو بشكل مخفي بحيث تكون القيمة بلون ارضيه الخلية ) تقبل خالص تحياتى اولا : احب انوه عن شكرى وتقديري لمجهودك الرائع استاذي الفاضل ثانيا : بالنسبه لاستفسارك ليه لو العدد اكثر من 29 لا يتم الترحيل لان تنسيق الورقه لا يقبل اكثر من 29 اسم ثم يليها المجموع لعدة اوراق اخرى ولو كان مدخل البيانات حدد نوع واحد من الكشوف اكثر فاكيد سوف يسقط الزائد عن عدد الورقه او يتم مسح المجموع اسفل الورقه فاردت عند الترحيل يكون على حجم الورقه فقط ثالثا : ودا الاهم فعلا الكود يعمل جيدا ولكن فيه مشكله بسيطه لو استطعت حلها وهي عدم ظهور رسالة التحذير بان البيانات اكثر من 29 لانى عملت تجربه واضفت 32 اسم في كشف 1 وتم استخدام الكود وتم ترحيل 29 فقط ولم تظهر الرساله اريد اذا كان عدد الكشف المختار اكثر من 29 لا يتم ترحيل البيانات وتظهر رساله تفيد بان العدد اكثر من حجم الورقه ولك مني الف شكر واحترام وشكرا لمجهودك الرائع رابط هذا التعليق شارك More sharing options...
خالد الرشيدى قام بنشر مايو 17, 2017 مشاركة قام بنشر مايو 17, 2017 (معدل) السلام عليكم تفضل اخي الكريم علة المطلوب تماماً Sub Add() Dim LR, LE As Long '=========================================================== Dim sh1 As Worksheet: Set sh1 = Sheets("بيانات اساسية") Dim sh2 As Worksheet: Set sh2 = Sheets("كشف") LE = sh1.Cells(Rows.Count, "Q").End(xlUp).Row ' sh1 بشيت Range("B6:B" & LE) بدلاله النطاق A1 عدد مرات تكرار اسم الكشف الموجود في شيت كشف خليه If Application.WorksheetFunction.CountIf(sh1.Range("B6:B" & LE), sh2.Range("a1").Value) > 29 Then MsgBox "لا يمكن استدعاء كل البيانات " ' تفريغ نطاق نتيجة البحث بشيت كشف sh2.Range("B6:BH35").ClearContents ' انهاء عمل الكود Exit Sub End If ' ان لم يتحقق الشرط السابق بحيث عدد النتائج اقل من او يساوي 29 ' تفريغ نطاق نتيجة البحث بشيت كشف ' بحيث يهيأ لاستقبال النتائج الجديده فى كل مرة sh2.Range("B6:BH35").ClearContents '=========================================================== ' وقف اهتزازات الشاشة اثناء عمل الكود Application.ScreenUpdating = False '=========================================================== Dim cll As Range 'sh1.Range("B6:B" & LE) عمل حلقة تكرارية - ساقية - علي كل صفوف النطاق For Each cll In sh1.Range("B6:B" & LE) 'sh2.Range("A1") لو ان قيمتها تساوي قيمة الخلية If cll.Value = sh2.Range("A1").Value Then ' انسخ الصف الذي تحقق به الشرط sh1.Range("Q" & cll.Row & ":BX" & cll.Row).Copy 'شيت كشف B لصق الصف في اول خليه فارغة في العمود sh2.Range("B" & sh2.Range("B35").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues ' انتهي الشرط End If ' نقطه بدء ونهاية الساقيه لحين الانتهاء من الدوران على كافة الصفوف المحددة Next ' ازالة التحديد عن النطاق المنسوخ Application.CutCopyMode = False ' اعادت تحديثات الشاشه Application.ScreenUpdating = True End Sub تفضل المرفق استدعاء بيانا_2.rar تم تعديل مايو 17, 2017 بواسطه خالد الرشيدى 1 رابط هذا التعليق شارك More sharing options...
ابو حمادة قام بنشر مايو 17, 2017 الكاتب مشاركة قام بنشر مايو 17, 2017 4 ساعات مضت, خالد الرشيدى said: السلام عليكم تفضل اخي الكريم علة المطلوب تماماً Sub Add() Dim LR, LE As Long '=========================================================== Dim sh1 As Worksheet: Set sh1 = Sheets("بيانات اساسية") Dim sh2 As Worksheet: Set sh2 = Sheets("كشف") LE = sh1.Cells(Rows.Count, "Q").End(xlUp).Row ' sh1 بشيت Range("B6:B" & LE) بدلاله النطاق A1 عدد مرات تكرار اسم الكشف الموجود في شيت كشف خليه If Application.WorksheetFunction.CountIf(sh1.Range("B6:B" & LE), sh2.Range("a1").Value) > 29 Then MsgBox "لا يمكن استدعاء كل البيانات " ' تفريغ نطاق نتيجة البحث بشيت كشف sh2.Range("B6:BH35").ClearContents ' انهاء عمل الكود Exit Sub End If ' ان لم يتحقق الشرط السابق بحيث عدد النتائج اقل من او يساوي 29 ' تفريغ نطاق نتيجة البحث بشيت كشف ' بحيث يهيأ لاستقبال النتائج الجديده فى كل مرة sh2.Range("B6:BH35").ClearContents '=========================================================== ' وقف اهتزازات الشاشة اثناء عمل الكود Application.ScreenUpdating = False '=========================================================== Dim cll As Range 'sh1.Range("B6:B" & LE) عمل حلقة تكرارية - ساقية - علي كل صفوف النطاق For Each cll In sh1.Range("B6:B" & LE) 'sh2.Range("A1") لو ان قيمتها تساوي قيمة الخلية If cll.Value = sh2.Range("A1").Value Then ' انسخ الصف الذي تحقق به الشرط sh1.Range("Q" & cll.Row & ":BX" & cll.Row).Copy 'شيت كشف B لصق الصف في اول خليه فارغة في العمود sh2.Range("B" & sh2.Range("B35").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues ' انتهي الشرط End If ' نقطه بدء ونهاية الساقيه لحين الانتهاء من الدوران على كافة الصفوف المحددة Next ' ازالة التحديد عن النطاق المنسوخ Application.CutCopyMode = False ' اعادت تحديثات الشاشه Application.ScreenUpdating = True End Sub تفضل المرفق استدعاء بيانا_2.rar تسلم استاذي الغالي هو دا المطلوب الله ينور عليك ويجعله في ميزان حسناتك وزادك الله علما 1 رابط هذا التعليق شارك More sharing options...
خالد الرشيدى قام بنشر مايو 17, 2017 مشاركة قام بنشر مايو 17, 2017 جزاك الله خيراً اخي الكريم على هذا الدعاء الطيب وجزالك الله بمثله ان شاء الله الحمد لله ان تم المطلوب .. الحمد لله الذي بنعمته تتم الصالحات 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.