سليم حاصبيا

المطلوب غير واضح نهائياً ضع في جدول مستقل النتائج المتوقعة(يدوياً)

لا ضرورة لرفع ملف فيه الوف الصفوف و تنسيقات مزركشة مما يزيد حجم الملف الى أكثر من واحد ميغا لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الألوف من الصفوف جرب ان تفعل في الورفة كما في الصورة المرفقة 1- تغيير اسمها الى اي شيئ شرط باللغة الاجنبية (لحسن نسخ الماكرو ولصقه) انا اسميتها Salim 2- اضافة صفين فارغين نماماً (اركز على كلمة فارغين تماماً) الصف رقم 2 والصف رقم 4 (هذه الصفوف مخفية للمنظر من حهة ولعدم كتابة اي شيء فيها عن طريق الحطأ من جهة اخرى) بحيث تيدأ البيانات من الصف الخامس الصف رقم3 عناوبن (وذلك لفصل البياتات المتغيرة غن الثابتة) 3- نفذ هذا الماكرو Sub Serial_number() Dim Rg_A As Range Dim Lra#, k%, i% k = 1 With Sheets("Salim") Set Rg_A = .Range("A5").CurrentRegion.Columns(1) Rg_A.ClearContents Lra = Rg_A.Rows.Count - 1 For i = 5 To Lra .Cells(i, 1) = k k = k + 1 i = i - 1 + .Cells(i, 1).MergeArea.Rows.Count Next End With End Sub mh_syr.xlsm

اين ذهبت الأرقام؟؟؟؟ اليك الملف كاملاً مع زر الطباعة Ritage_With_Print.xlsm

لا أعلم السبب عندك سبب طهور الرسالة هو ان هذه الرحلة موجودة فعلاً لذلك يجب 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

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

see thid video https://www.youtube.com/watch?v=N3koQF2_O8k&ab_channel=MITutorials

لعكس الترتيب استبدل قي هذا السطر من الكود الرقم 2 بالرقم 1 Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1 تم التعديل على الملف كما تريد ( و زيادة حبتين من حيث التنسيق) Option Explicit Sub From_dash_to_data() Dim Dash As Worksheet, Dt As Worksheet Dim Cret As Range, x%, y%, Ro_D Application.ScreenUpdating = False Set Dash = Sheets("Dashboard"): Set Dt = Sheets("DATA") Dash.Range("A3").CurrentRegion.Clear Ro_D = Dt.Range("A3").CurrentRegion.CurrentRegion.Rows.Count If Dash.Range("C1") = "" Then MsgBox "Pleae Type A number In The cell C1" & Chr(10) & _ "Last Than " & Ro_D - 2 GoTo Bay_Bay End If If Not IsNumeric(Dash.Range("C1")) Then MsgBox "Tex Not Allowed in The cell C1" & Chr(10) & _ "Pleae Type A number" GoTo Bay_Bay End If y = Int(Abs(Dash.Range("C1"))) Dash.Range("C1") = y Set Cret = Dash.Range("A1") Dt.Range("A1").CurrentRegion.AutoFilter 1, Cret Dt.Range("A1").CurrentRegion.SpecialCells(12).Copy Dash.Range("A3").PasteSpecial (12) Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1 x = Dash.Range("A3").CurrentRegion.CurrentRegion.Rows.Count If x - y < 2 Then With Dash.Range("A4").Offset(x - 1, 2) .Value = Evaluate("=SUM(C4:C" & x + 2 & ")") .Interior.ColorIndex = 3 .Font.ColorIndex = 2 End With Else Dash.Range("A4").Offset(y) _ .Resize(x - y - 1).EntireRow.Delete With Dash.Range("A3").Offset(y + 1, 2) .Value = Evaluate("=SUM(C4:C" & y + 3 & ")") .Interior.ColorIndex = 3 .Font.ColorIndex = 2 End With End If Application.CutCopyMode = False If Dt.AutoFilterMode Then Dt.Range("A1").AutoFilter Dash.Activate With Dash.Range("A3").CurrentRegion .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Rows(1).Interior.ColorIndex = 35 .Rows(1).HorizontalAlignment = 3 End With Dash.Range("A3").Select Bay_Bay: Application.ScreenUpdating = True End Sub الملف من جديد Hashem_Super.xlsm

جرب هذا الماكرو Option Explicit Sub test() Dim Ro%, Rg As Range Dim x%, t%, i% With Sheets("ورقة1") Ro = .Cells(Rows.Count, 1).End(3).Row Set Rg = .Range("A1:A" & Ro).SpecialCells(2, 23) .Range("E1").Resize(Ro, 2).Clear t = 1 For x = 1 To Rg.Areas.Count .Cells(t, "E").Resize(Rg.Areas(x).Rows.Count) = _ Rg.Areas(x).Cells(1, 1) .Cells(t, "E").Interior.ColorIndex = 6 For i = 2 To Rg.Areas(x).Rows.Count .Cells(t + 1, "F").Offset(i - 2) = _ Rg.Areas(x).Cells(i).Offset(, 2) Next i t = t + Rg.Areas(x).Rows.Count + 1 Next x With .Range("E1").Resize(Ro, 2).SpecialCells(2, 23) .Borders.LineStyle = 1 .Font.Bold = True .InsertIndent 1 End With End With End Sub الملف مرفق Sakr_Khalige.xls

يجب ابقاء الصف رقم 2 فارغاً (لقصل البيانات المتغيرة عن الثابتة) تم اخفاءه والبيانات تبدأ من الصف رقم 3 الماكرو Option Explicit Sub From_dash_to_data() Dim Dash As Worksheet, Dt As Worksheet Dim Cret As Range, x%, y% Set Dash = Sheets("Dashboard"): Set Dt = Sheets("DATA") If Not IsNumeric(Dash.Range("C1")) Then Exit Sub End If y = Int(Abs(Dash.Range("C1"))) Dash.Range("C1") = y Dash.Range("A3").CurrentRegion.ClearContents Set Cret = Dash.Range("A1") Dt.Range("A1").CurrentRegion.AutoFilter 1, Cret Dt.Range("A1").CurrentRegion.SpecialCells(12).Copy Dash.Range("A3").PasteSpecial (12) Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1 x = Dash.Range("A3").CurrentRegion.CurrentRegion.Rows.Count Dash.Range("A4").Offset(y) _ .Resize(x - y - 1).EntireRow.Delete Dash.Range("A3").Offset(y + 1, 2) = _ Evaluate("=SUM(C4:C" & y + 3 & ")") Application.CutCopyMode = False If Dt.AutoFilterMode Then Dt.Range("a1").AutoFilter Dash.Activate Dash.Range("A3").Select End Sub File Included Hashem.xlsm

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

جرب هذا الكود للترحيل الى 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- الى اين الترحيل (اي صفحة) 2- الخانات المطلوب ترحيلها 3- ضقحة القواتير تحتوي على حلايا في كل صف اكثر من خلايا Invoice الخ... من الأشياء الغامضة

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

Try this macro Option Explicit '''''''''''''''''''''''''''''''''''' Dim LR%, Ro%, S_rg As Range Dim F_rg As Range, Where As Range Dim i%, t%, LRK%, x%, m% Dim y1%, y2%, ro_source% '++++++++++++++++++++++++++++++++++++++++ '++++++++++++++++++++++++++++++++++++++++ Sub TEST() Rem Created By Salim Hasbaya On 8/10/2020 _ This macro working with merged cells _ And sort Alpha the Data Application.ScreenUpdating = False Dim Col As Object Set S_rg = Source.Range("A3").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Ro = S_rg.Rows.Count SALIM.Range("K:K").ClearContents SALIM.Range("A3").CurrentRegion.Clear If Ro = 1 Then Exit Sub Set S_rg = S_rg.Offset(1).Resize(Ro - 1) For i = 3 To Ro + 2 t = Source.Cells(i, 2).MergeArea.Rows.Count If Not Col.Contains(Source.Cells(i, 2).Value) Then Col.Add Source.Cells(i, 2).Value End If i = i + t Next If Col(Col.Count - 1) = "" Then Col.Remove Col(Col.Count - 1) End If Col.Sort SALIM.Range("K1").Resize(Col.Count) = _ Application.Transpose(Col.toarray) Set Col = Nothing Application.ScreenUpdating = True End Sub '+++++++++++++++++++++++++++++++++++ Sub get_data() Application.ScreenUpdating = False TEST Dim p%, Merge_Rg As Range ro_source = Source.Cells(Rows.Count, 2).End(3).Row Set Where = Source.Range("B1:B" & ro_source) LRK = SALIM.Cells(Rows.Count, "K").End(3).Row m = 3 For x = 1 To LRK Set F_rg = Where.Find(SALIM.Cells(x, "K"), Lookat:=1) If Not F_rg Is Nothing Then y1 = F_rg.Row: y2 = y1 Do t = F_rg.MergeArea.Rows.Count SALIM.Cells(m, 2) = Source.Cells(y2, 2) SALIM.Cells(m, 4) = Source.Cells(y2, 4) SALIM.Cells(m, 2).Resize(t).Merge SALIM.Cells(m, 4).Resize(t).Merge Set Merge_Rg = Source.Cells(y2, 1).Resize(t) For p = 1 To Merge_Rg.Rows.Count SALIM.Cells(m, 1).Offset(p - 1) = _ Merge_Rg.Cells(p) SALIM.Cells(m, 3).Offset(p - 1) = _ Merge_Rg.Cells(p).Offset(, 2) Next m = m + t Set F_rg = Where.FindNext(F_rg) y2 = F_rg.Row If y2 = y1 Then Exit Do Loop End If Next With SALIM.Range("A3").CurrentRegion .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 16: .Font.Bold = True .HorizontalAlignment = 3 .VerticalAlignment = 2 .Interior.ColorIndex = 35 End With SALIM.Range("K:K").ClearContents Application.ScreenUpdating = True End Sub File Included Abd_Naser.xlsm

انا قمت بما هو مطلوب والواضح في سؤالك أريد استدعاء بيانات من شيت "الرحلات - المعتمرين " حسب رقم الرحلة" الى شيت invoice لجلب الاسماء المسجلين في شيت "الرحلات – المعتمرين"

لم افهم عليك ما تريد اكنب في الورقة الثانية التنائج التي تتوقعها

جرب هذا الكود 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

لقد رفعت لك ملفاً مشابهاً لما تريد حاول الدخول الى الكود فيه والتعديل غليه ليتناسب مع ما تريد

تم تشغيل الصفحة الثانية من اليوزر (Chrecher) 1- في هذه الصفحة اضغط على الكومبوبوكس قتظهر لك البيانات في التكست بوكسات 2- قم بنعديل ما تريد ثم أضغظ الزر (Modifier) لتنتقل البيانات الى الصفجة test1 RJS .xlsm

جرب هذا الملف الصفحة Master (و لا حاجة لهذا الكم الهائل من التنسيق الشرطي) Option Explicit Dim m%, x%, t%, k% Dim cel As Range '++++++++++++++++++++++ Sub fil_data() Empty_cel test_vertical test_Horizontal End Sub '+++++++++++++++++++++++++++++++ Sub Empty_cel() Dim ro%, col% Dim ar_col() Dim Clr%, Rg As Range ro = Cells(Rows.Count, "F").End(3).Row If ro < 9 Then ro = 9 Cells(9, "F").Resize(ro, 2).ClearContents col = Cells(8, Columns.Count).End(1).Column If col < 8 Then col = 8 Cells(8, 8).Resize(, col - 10).ClearContents For Each Rg In Range("Mawad").Columns(1).Cells Select Case Rg.Value Case "عربية": Clr = 4 Case "إسلامية": Clr = 6 Case "رياضيات": Clr = 20 Case "فرنسية": Clr = 38 Case "إنجليزية": Clr = 40 Case Else: Clr = xlNone End Select Rg.Resize(, 2).Interior.ColorIndex = Clr Next '++++++++++++++++++++++++++++ For Each Rg In Range("Mustwa").Columns(1).Cells Select Case Rg.Value Case "4م": Clr = 4 Case "3م": Clr = 6 Case "2م": Clr = 20 Case "1م": Clr = 38 Case Else: Clr = xlNone End Select Rg.Resize(, 2).Interior.ColorIndex = Clr Next End Sub '++++++++++++++++++++++++++++ Sub test_vertical() x = 9 m = Range("Mawad").Rows.Count For Each cel In Range("Mawad").Columns(1).Cells Cells(x, "F").Resize(cel.Offset(, 1)).Value = _ cel For k = 1 To cel.Offset(, 1) Cells(x, "F").Offset(, 1).Offset(k - 1) = _ cel & " : " & k Next Cells(x, "F").Resize(cel.Offset(, 1), 2) _ .Interior.ColorIndex = cel.Interior.ColorIndex x = x + cel.Offset(, 1) Next End Sub '+++++++++++++++++++++ Sub test_Horizontal() x = 8: t = 8 m = Range("Mustwa").Rows.Count For Each cel In Range("Mustwa").Columns(1).Cells For k = 1 To cel.Offset(, 1) Cells(x, t).Offset(, k - 1) = cel & " : " & k Next Cells(x, t).Resize(, cel.Offset(, 1)).Interior.ColorIndex = _ cel.Interior.ColorIndex t = t + cel.Offset(, 1) Next End Sub '++++++++++++++++++++++++++++ الملف مرفق MOSTACHAR.xlsm

Try This code Option Explicit Sub ww() Dim h As Worksheet, sh As Worksheet Dim cnt% Set h = Sheets("sheet1") h.Range("B2").Resize(Sheets.Count - 1).ClearContents cnt = 2 For Each sh In Sheets If Not sh.Name = "Sheet1" Then h.Hyperlinks.Add Anchor:=h.Cells(cnt, 2), _ Address:="", SubAddress:=sh.Name & "!A1", _ TextToDisplay:="Go to " & sh.Name h.Cells(cnt, 2).Font.Size = 16 sh.Cells(1, 6).ClearContents sh.Hyperlinks.Add Anchor:=sh.Cells(1, 6), _ Address:="", SubAddress:=h.Name & "!A1", _ TextToDisplay:="Go to " & h.Name sh.Cells(1, 5) = h.Cells(cnt, 3) cnt = cnt + 1 End If Next End Sub

لك ما تريد Ashraf.xlsx

يمكن عمل ذلك بمعادلة بسيطة ولا ضرورة للكود مثال قي الملف المرفق الاسماء الأساسية في الصفحة Source ويوجد عنها نسخة مرتبطة بها في الصقحة Target اذا حذفت (اسم او عدة اسماء) او اضفت ( اسم او عدة اسماء ) في الصفحة Source تتغير البيانات في Target Dynamic_names.xlsx

أولاً لم افهم عليك ماذا تريد ثانياً هذا مثال لكيفية غمل التنسيق حسب قيمة الخلية (هنا تم استعمال استدعاء الكود Incolor_me من الكود Talween) لزبادة وضوح الصورة Option Explicit Sub Talween() Dim My_cel As Range Dim Rg As Range Dim x% Incolor_me Set Rg = Range("A1").CurrentRegion For Each My_cel In Rg Select Case My_cel Case vbNullString: GoTo Next_i Case Is < 0: x = 35 Case Is = 0: x = 6 Case Is > 0: x = 40 End Select My_cel.Interior.ColorIndex = x Next_i: Next End Sub '++++++++++++++++++++++++++++++ Sub Incolor_me() Range("A1").CurrentRegion.Interior.ColorIndex = xlNone End Sub الملف مرفق Colorize.xlsm