اذهب الي المحتوي
أوفيسنا

كودلاستدعاء البيانات بناء على اسم يتم اختياره

ابو حمادة

بواسطه ابو حمادة
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
12 ساعات مضت, ابو حمادة said:

59197c54d1803_.PNG.6435696a8381041f7d40181cf402f2c9.PNG

مرفق ملف

استدعاء بيانا.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

يريت حد يساعدني في تعديله

 

 

 

 

رابط هذا التعليق
شارك
ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
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

يريت حد يساعدني في تعديله

 

 

 

 

ايه الموضوع صعب اوى ولا ايه

مش شايف اي رد نهائي

 

رابط هذا التعليق
شارك
ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
4 دقائق مضت, خالد الرشيدى said:

السلام عليكم

اى عمود بصفحه البيانات الاساسية يحدد اسم الكشف ؟؟؟؟؟؟؟؟؟

اي عمود مش هاتفرق وانا اعدل عليه عادي وليكن مثلا في العمودي ( B )

رابط هذا التعليق
شارك
خالد الرشيدى

خالد الرشيدى

قام بنشر
قام بنشر (معدل)

اخي الكريم

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

استدعاء بيانا_2.rar

( تم الغاء دمج الخلايا B3:B5 لانه من شأنه ان يفسد عمل الكود .. يمكنك ان تدمج B3:B4 ولكن ضع اى قيمه في B5  ولو بشكل مخفي بحيث تكون القيمة بلون ارضيه الخلية ) 

تقبل خالص تحياتى 

تم تعديل بواسطه خالد الرشيدى
  • Like 1
رابط هذا التعليق
شارك
خالد الرشيدى

خالد الرشيدى

قام بنشر
قام بنشر (معدل)
2 ساعات مضت, ابو حمادة said:

ايه الموضوع صعب اوى ولا ايه

مش شايف اي رد نهائي

اخى الكريم 

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

تقبل مرورى وتحياتى 

تم تعديل بواسطه خالد الرشيدى
  • Like 1
رابط هذا التعليق
شارك
ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
13 ساعات مضت, خالد الرشيدى said:

اخي الكريم

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

استدعاء بيانا_2.rar

( تم الغاء دمج الخلايا B3:B5 لانه من شأنه ان يفسد عمل الكود .. يمكنك ان تدمج B3:B4 ولكن ضع اى قيمه في B5  ولو بشكل مخفي بحيث تكون القيمة بلون ارضيه الخلية ) 

تقبل خالص تحياتى 

اولا  :  احب انوه عن شكرى وتقديري لمجهودك الرائع استاذي الفاضل 

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

ثالثا  :  ودا الاهم  فعلا الكود يعمل جيدا ولكن فيه مشكله بسيطه لو استطعت حلها وهي عدم ظهور رسالة التحذير بان البيانات اكثر من 29  لانى عملت تجربه واضفت 32 اسم في كشف 1 وتم استخدام الكود وتم ترحيل 29 فقط ولم تظهر الرساله 

اريد اذا كان عدد الكشف المختار اكثر من 29 لا يتم ترحيل البيانات وتظهر رساله تفيد بان العدد اكثر من حجم الورقه

ولك مني الف شكر واحترام

وشكرا لمجهودك الرائع

رابط هذا التعليق
شارك
خالد الرشيدى

خالد الرشيدى

قام بنشر
قام بنشر (معدل)

السلام عليكم

تفضل اخي الكريم علة المطلوب تماماً 

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

تم تعديل بواسطه خالد الرشيدى
  • Like 1
رابط هذا التعليق
شارك
ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
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

تسلم استاذي الغالي  هو دا المطلوب الله ينور عليك ويجعله في ميزان حسناتك وزادك الله علما

 

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept