اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

إستدعاء بيانات


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

 

أولا :أشكر كل المشاركين في هذا الموقع الممتاز 

ثانيا :أريد استدعاء  بيانات  من  شيت "الرحلات - المعتمرين "  حسب رقم الرحلة" 

 الى  شيت invoice لجلب الاسماء المسجلين في   شيت "الرحلات – المعتمرين"

كما هو واضح بالشكل  المرفق

راجيا المساعدة 

وان تعذر   ذلك ابداء ملاحظات  لي لكي يتسنى لي تعديلها بما يتوافق مع الامكانيات

شكرا لكم

برنامج.xlsm

88.png

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

جرب هذا الكود

Option Explicit

Private SR As Worksheet
Private Inv As Worksheet
Private Sr_rg As Range
Private Inv_rg As Range
Private Cret As Range
Private Ro_Sr#, ro_Inv#, Ro_march As Range
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub Get_data()
Application.ScreenUpdating = False
Set SR = Sheets("الرحلات_المعتمرين")
Set Inv = Sheets("Invoice")
Inv.Range("I13").CurrentRegion.Clear
 If Inv.Range("E7") = vbNullString Then
  MsgBox " E7 من فضلك اكتب رقم الرحلة في الخلية  "
  GoTo Bay_Bay
 End If
 
Set Sr_rg = SR.Range("A2").CurrentRegion
Set Ro_march = Sr_rg.Columns(1).Find(Inv.Range("E7"), lookat:=1)
  If Ro_march Is Nothing Then
    MsgBox " E7 الرقم غير صحيح في الخلية  "
  GoTo Bay_Bay
  End If
Ro_Sr = Sr_rg.Rows.Count
Set Cret = Inv.Range("E7")
Sr_rg.AutoFilter 1, Cret
Sr_rg.Columns(9).Offset(1).Resize(Ro_Sr - 1).SpecialCells(12).Copy
Inv.Range("J13").PasteSpecial (11)
ro_Inv = Inv.Range("I13").CurrentRegion.Rows.Count
Inv.Range("I13").Resize(ro_Inv) = _
 Evaluate("row(1:" & ro_Inv & ")")
      With Inv.Range("I13").CurrentRegion
         If .Rows.Count > 1 Then
          .Borders.LineStyle = 1
          .Font.Size = 18: .Font.Bold = True
          .InsertIndent 1
          .Interior.ColorIndex = 35
          .Cells(1, 1).Select
         End If
      End With
Bay_Bay:
Application.CutCopyMode = False
Application.ScreenUpdating = True
If SR.AutoFilterMode Then Sr_rg.AutoFilter
End Sub

الملف مرفق

 

Ritage.xlsm

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

الاستاذ سليم حاصبيا الكريم 

اشكرك وجبر الله بخاطرك على طيب تواضعك وبارك اللله بعلمك 

الان جربت الاجابة رائعة وهو المطلوب 

ولكن استاذنا 

اريد ان يكون الملف شامل حيث  لاحظت  ان الحل اقتصر   على الورقيتن فقط

كما هناك طلب آخر وهو موجود بالرسمة المرفقة 

 ودمتم لهذا الصرح العملاق   

توضيح5.png

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

انا قمت بما هو مطلوب والواضح في سؤالك

أريد استدعاء  بيانات  من  شيت "الرحلات - المعتمرين "  حسب رقم الرحلة" 

 الى  شيت invoice لجلب الاسماء المسجلين في   شيت "الرحلات – المعتمرين"

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

الاستاذ سليم حاصبيا

اشكرك جدا ودام عطاؤك الى هذا الصرح العملاق 

وكان عندي أمل أن تجيب على باقي أسألتي الموجودة بالشكل 

لكن ليس على الكريم الشرط  

كل المحبة 

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

المطلوب شرح ما تريد بالضبط

1- الى اين الترحيل  (اي صفحة)
2- الخانات المطلوب ترحيلها
3- ضقحة القواتير تحتوي على حلايا في كل صف اكثر من خلايا Invoice
الخ... من الأشياء الغامضة

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

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

لاني فتحت صفحة الفواتير ولم أجد الغرفة الثنائية ولا الثلاثية الخ...... عدا عن اشياء اخرى

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

الصفحة Invoice  كما تلاحظ   انت مشكور قمت بإستدعاء الاسماء ويوجد على يمين الاسماء جدول التسكين وهذا سهل علي تسكين الناس من خلال الاسماء الموجودة التي استدعيناها  بالتالي اصبحت هذه الصفحة  تحتوي على الاسماء + التسكين 

الصفحة data تكون سجل لحفظ   تسكين  الرحلات جميعها بحيث اذا  تمكنا من  استدعاء  تسكين اي  رحلة  متى اردنا ذلك  

اشكرك 

ارجو ان اكون قد وضحت و وصلت الفكرة لكم 

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

استاذنا الكبير  سليم حاصبيا 

صفحة Invoice   = للتسكين والاسماء لكل رحلة 

صفحة data  = لحفظ جميع   تسكين الرحلات جميعها 

زر ( ترحيل الفاتورة)  اي يرحل التسكين الى صفحة data

زر ( استدعاءاو حذف الفاتورة )  اي استدعاء جدول تسكين رحلة رقم XXX   من صفحة data

 

كل المحبة 

 

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

جرب هذا الكود للترحيل الى Data (الزر الاخضر) الترحيل لا يتكرر

الغرقة المحجوزة تكتب فيها "Ok"

Option Explicit
Private D As Worksheet
Private Inv As Worksheet
Private D_rg As Range, Inv_rg As Range
Private where_D As Range
Private where_Inv As Range
Private Ro_D#, ro_Inv#, m#, col#
'++++++++++++++++++++++++++++++++++
Sub From_Inv_to_Sh_data()
Set D = Sheets("Data")
Set Inv = Sheets("Invoice")

Dim Rehla: Rehla = Inv.Cells(7, "E") 'B
Dim Dt: Dt = Inv.Cells(8, "D") 'C
Dim ReH_Size: ReH_Size = Inv.Cells(9, "D") 'd
Dim Hafila: Hafila = Inv.Cells(9, "F") 'E
Dim Murshed: Murshed = Inv.Cells(10, "D") 'F
 
 Ro_D = D.Cells(Rows.Count, 2).End(3).Row + 1
 m = 13

 Do Until Inv.Range("I" & m) = vbNullString
  Set where_Inv = Inv.Range("B" & m).Resize(, 5).Find("Ok")

  If Not where_Inv Is Nothing Then
    col = where_Inv.Column
    Set where_D = D.Range("B3:K3").Find(Inv.Cells(11, col), lookat:=1)
     
      If Not where_D Is Nothing Then
       D.Range("B" & Ro_D) = Rehla
       D.Range("C" & Ro_D) = Dt
       D.Range("D" & Ro_D) = ReH_Size
       D.Range("E" & Ro_D) = Hafila
       D.Range("F" & Ro_D) = Murshed
       D.Cells(Ro_D, where_D.Column) = where_Inv
       D.Cells(Ro_D, "k") = Inv.Range("G" & m)
       D.Cells(Ro_D, "L") = Inv.Range("J" & m)
       Ro_D = D.Cells(Rows.Count, 2).End(3).Row + 1
      End If
  End If
  m = m + 1
 Loop
 D.Range("B3").CurrentRegion.RemoveDuplicates _
 Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11), Header:=1
 Ro_D = D.Cells(Rows.Count, 2).End(3).Row
 
 With D.Range("B4").Resize(Ro_D - 3, 11)
 .Borders.LineStyle = 1
 .Font.Size = 14: .Font.Bold = True
 .Interior.ColorIndex = 19
 End With
End Sub

الملف مرفق

Ritage_New.xlsm

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

استاذنا الكبير  سليم حاصبيا المحترم 

مرة أخرى جزاك الله عنا كل خير فهي اعظم دعاء 

واريد ان اوضح لكم 

كما هو واضح بالشكل المرفق 

1- انا اقوم بتسجيل   اسماء المعتمرين  في كشف التسكين  في ( صفحة Invoice  وذلك  بعد استدعاء الاسماء المسجلين لرحلة مثلا 101  من الجدول الذي موجود على اليسار حسب رغبات الناس  . وهذا الامر تم بسلاسة كما هو واضح بالشكل المرفق

من المعتمرين  من يختار  غرفة ثلاثبة او  غرفة رباعية او............... (  اي نقل اسماء فقط بشكل يدوي بدون كود )  وهذا كلة تمام كما تلاحظ من الشكل المرفق 

2-  المشكلة  تكمن  في انني اريد ترحيل  كشف التسكين لرحلة مثلا 101  بعد تسجيل الاسماء وتوزيعهم على الغرف الى صفحة صفحة data: 

أ - لكي يتاح لي اعداد  كشف تسكين   لرحلة  اخرى مثلا 102 ..103...104  الخ  

ب- ايضا حتى اذا رغبت في استدعاء كشف التسكين مرة اخرى رحلة 101... لكي اتمكن من اجراء اي   تعديل على الكشف اذا تم مثلا تغير بعض المسجلين من غرفة ثلاثية الى رباعية ..... الخ  او استدعاء كشف الاسماء مثلا للطباعة او ...........الخ .

املا ان اكون وضحت الفكرة لكم ومرة اخرى جزاك الله عنا كل خير 

1000.png

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

لتبسيط العمل

ارى انه من الافضل كتابة نوع الغرفة امام كل اسم (   في العامود  "L"  لفصله عن بقية البيانات بعامود فارغ "  K " 
 في الصورة العامود "  K "  فارغ (محفي )
    2=ثنائية /  3=ثلاثية   وهكذا اختصاراً   للوقت   ثم الضغط على الزر الأخضر

لاستدعاء البيانات اضغط الزر استدعاء
الصورة توضح ذلك 

 

 

Screenshot_2.png

 

Ritage_Super_with_dict.xlsm

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

أستاذنا  الكبير سليم حاصبيا

جزاك الله عنا كل خير ، فهي اعظم دعاء 

عمل  رااااااااااااااااااااااااااااااااااااااااااااااائع  و    كله إبدااااااااااااااااااااااع  

ولكن اتحملني طلب صغير 

1- يا ريت  توفير  امكانية  اجراء التعديل على كشف التسكين  بعد الاستدعاء   ،

وارد جداً  أن يغير بعض  الناس سكنه من ثلاثي .... الى رباعي  او ...الى .............الخ

كل المحبة والتقدير  لك استاذنا وعلى صبرك وتحملك لطلباتنا 

2- زر طباعة لكشف التسكين 

🌴زينة العلم التواضع وانت أهل لذلك 🌴.

🌴🌴🌴جزاك الله عنا كل خير  .... 🌴🌴

دام عطاؤك لهذا الصرح العملاق 🌴🌴🌴

 

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

      لاجراء اي تعديل اتبع الحطوات حسب الصورة

 1- حدد رقم الرحلة (المربع الأزرق)
 2- اضغط الزر رقم 2  (يتم مسح البيانات الخاصة بالرحلة   /التابعة للمربع الأزرق/   من الشيت داتا)
 3- اضغط الزر رقم 3 (يتم جلب البيانات من الشيت الأساسية "الرحلات_المعتمرين" الى العامودين   (اللون الأخضر)
 4- قم بتعديل ما تريد في عامود (نوع الغرفة) 
 5-  اضغط الزر رقم 5  (تذهب البيانات الجديدة الى الشيت داتا) أحر صف كان غير فارغ
 6-اضغط الزر رقم 6 (لنقل الاسماء بعد التعديل الى الجدول)

Hashem.png

مرفق الملف معدلاً

 

Ritage_Final_File.xlsm

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

أستاذنا  الكبير سليم حاصبيا

مرة اخرى اشكرك وجزاك الله عنا كل خير 

عملت على اجراء تعديل على السكن لاحد الناس لكن للاسف فشلت 

 قمت بجإجراء التعليمات التي كتبتها 

وعند النقطة رقم (5)  ( 5-  اضغط الزر رقم 5  (تذهب البيانات الجديدة الى الشيت داتا) أحر صف كان غير فارغ)

مع الاحترام والتقدير والعرفان لكم 

تغيير السكن.png

تعديل 1.png

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

لا أعلم السبب عندك

سبب طهور الرسالة هو ان هذه الرحلة موجودة فعلاً  لذلك يجب
1- حذفها أولاً من  الشيت داتا الزر رفم 2   لان الماكرو لا يضيفها اذا كانت موجودة في هذا الشيت( لا يسمح بالتكرار)
2- اجراء التعديلات اللازمة
3-ارسالها الى الشيت داتا من جديد  الزر رفم 5

4-التأكد من ان كل شيء في مكانه الصحيح بواسطة  الزر  6  استدعاء

عندي بعمل بشكل طبيعي   تأكد من  اجراء الخطوات بشكل صحيح

 

Pic_2.png

بالنسبة للطباعة هذا الكود

Sub Print_Me()
Dim My_last%, Inv As Worksheet
Set Inv = Sheets("Invoice")
My_last = Application.Max(Inv.Range("B13:B32")) + 12
Inv.PageSetup.PrintArea = Inv.Range("B1:G" & My_last).Address
Inv.PrintPreview
End Sub

مع امكانية استبدال السطر (الذي يظهر منظر الصفحة قبل طباعتها)

Inv.PrintPreview

بهذا السطر (الذي يرسل الصفحة مباشرة الى الطباعة)

Inv.PrintOut

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

استاذي الكريم سليم حاصبيا

اشكرك  رااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااااائع  ومبدع  حقاً .

تم تصحيح الخطأ من قبلي حيث لم اقم بخطوة رقم 2 وهي ضرورية . 

والآن البرنامج راااااااااااااااااااااااااااااااااااااااااااائع  بفضل الله عز وجل ثم جهودك المبدعة. 

جزاك الله عنا كل خير ووسع ارزاقك وبارك بعمرك 

ودمت لهذا الصرح العملاق متألقاً ومبدعاً 

كل المحبة والتقدير والاحترام 

 

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information