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

[ريتاج المدينة]

 

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

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

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

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

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

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

شكرا لكم

برنامج.xlsm

[سليم حاصبيا]

جرب هذا الكود

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

[ريتاج المدينة]

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

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

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

ولكن استاذنا 

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

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

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

[سليم حاصبيا]

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

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

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

[ريتاج المدينة]

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

وهو المطلوب  ولكم كل الاحترام 

ولكن اريد ان يكون الحل بالملف الاصلي

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

 

[سليم حاصبيا]

هو نفس الملف لكن انا أخفيت الأوراق الزائدة (ولم أحذفها) لسهولة تتبع الماكرو  يمكنك اعادة اظهارها

[ريتاج المدينة]

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

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

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

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

كل المحبة 

[سليم حاصبيا]

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

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

[ريتاج المدينة]

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

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

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

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

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

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

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

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

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

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

تم تعديل أكتوبر 9, 2020 بواسطه ريتاج المدينة

[سليم حاصبيا]

لتبسيط العمل

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

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

 

 

 

Ritage_Super_with_dict.xlsm

[ريتاج المدينة]

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

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

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

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

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

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

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

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

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

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

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

 

تم تعديل أكتوبر 11, 2020 بواسطه ريتاج المدينة

[سليم حاصبيا]

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

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

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

 

Ritage_Final_File.xlsm

[ريتاج المدينة]

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

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

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

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

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

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

تم تعديل أكتوبر 11, 2020 بواسطه ريتاج المدينة

[سليم حاصبيا]

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

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

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

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

 

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

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

[ريتاج المدينة]

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

اشكرك 

وسامنحي غلبتك 

فقط استفسار بسيط باقي ان التعديل ظهر في شيت     data  ولم يظهر في invoice

سامحني غلبتك

 

[سليم حاصبيا]

اين ذهبت الأرقام؟؟؟؟

اليك الملف كاملاً مع زر الطباعة

 

Ritage_With_Print.xlsm

[ريتاج المدينة]

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

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

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

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

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

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

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