سليم حاصبيا

رائع اخي وجيه كنت اريد اسنعمال الدالة AGGREGATE لكن قلت في نفسي لعل اصدار الاكسل عند السائل قديم وبالتالي لا توجد هذه الدالة عنده نفس التعليق بالنسبة لـــ الاسماء غير مضبوطة

جرب هذا الملف abdelhalim.xlsx

اذكر ان الجدول يجب ان يكون مستقلاً عن كل الخلايا التي لا غلاقة له بها بصفوف فارغة وأعمدة فارغة) اجمع كل الأوراق التي تريدها في Array واحد و اعمل حلقة على هذا الـــ Array Option Explicit Sub Get_Spacial_Data() Dim A As Worksheet Dim sh As Worksheet Dim ar, itm Dim lr%, m%, t%, Mmax% Dim R_copy As Range Set A = Sheets("all") t = 4 If A.Range("A3").CurrentRegion.Rows.Count > 1 Then With A.Range("A3").CurrentRegion.Offset(1). _ Resize(A.Range("A3").CurrentRegion.Rows.Count - 1) .Interior.ColorIndex = xlNone .ClearContents End With End If '+++++++++++++++++++++++++++++++++++++++++ ' Add to the array the Sheets you want ar = Array("1", "2", "3", "4", "5", "6") '++++++++++++++++++++++++++++++++++++++ For Each itm In ar Set sh = Sheets(itm) Set R_copy = sh.Range("A3").CurrentRegion Mmax = R_copy.Rows.Count If Mmax > 1 Then With A.Cells(t, 1) .Resize(, 8).Interior.ColorIndex = 6 .Resize(Mmax - 1, 8).Value = _ sh.Range("A3").CurrentRegion.Offset(1).Resize(Mmax - 1).Value t = t + Mmax - 1 End With End If 'Mmax Next End Sub

جرب هذا الملف تم ادراج معلومات عشوائية (يمكن استبدالها بما تريد) تم حماية المعادلات لعدم العبث بها عن طريق الخطأ لا تقم بالترقيم لانه يدرج اوتوماتيكياًعند اكتمال الصف (4 عناصر) من B الى D (حتى 500 صف) Happy.xlsx

اضافة هذا السطر على الكود في المكان المناسب

جرب هذا الكود Option Explicit Sub Get_Data() Dim A As Worksheet Dim sh As Worksheet Dim ar(), itm Dim lr%, m%, t%, Mmax% Dim R_copy As Range Set A = Sheets("all") m = -1: t = 4 If A.Range("A3").CurrentRegion.Rows.Count > 1 Then With A.Range("A3").CurrentRegion.Offset(1). _ Resize(A.Range("A3").CurrentRegion.Rows.Count - 1) .Interior.ColorIndex = xlNone .ClearContents End With End If For Each sh In Sheets If sh.Name <> A.Name Then m = m + 1 ReDim Preserve ar(m) ar(m) = sh.Name End If Next If m > 0 Then For Each itm In ar Set sh = Sheets(itm) Set R_copy = sh.Range("A3").CurrentRegion Mmax = R_copy.Rows.Count If Mmax > 1 Then With A.Cells(t, 1) .Resize(, 8).Interior.ColorIndex = 6 .Resize(Mmax - 1, 8).Value = _ sh.Range("A3").CurrentRegion.Offset(1).Resize(Mmax - 1).Value t = t + Mmax - 1 End With End If 'Mmax Next End If 'm End Sub الملف مرفق Moustafa.xlsm

يا اخي كن واضحاً في سؤالك لاستدعاء البيانات من اوراق متعددة الى ورقة واحدة ما هي اوراق المصدر ؟؟؟ و ما هي الورقة الهدف ولم أر الماكرو المذكور في الملف الذي يحتوي على اكثر من Module فأين اريد ان اجده)

لاحظ هذه الصورة 1- في المريع الأحمر تضع اصفاراً حسب عدد الأعمدة المطلوبة ( في الصورة 4 أعمدة) 2- في المربع الأزرق تضع ارقام هذه الأعمدة (E=5 / F=6 / H=8 ) وهكذا

نم التعديل على الكود لتظهر أسماء الشيتات حيث الاسم موجود Ihab_ALL_new.xlsm

جرب هذا الملف 1- يمكن ان تختار اسم واحد أو كل الاسماء 2- الجمع يتم على الأعمدة E و F و I و J من كل صفحة (تم عمل حساب تكرار الاسم في الصفحة الواحدة) 3- يالنسبة للاسم الواحد Sub Data_Sum_1() Dim Res As Worksheet Dim Sh As Worksheet Dim ro1%, ro2%, K% Dim F_rg As Range Dim Ar Set Res = Sheets("Result") Ar = Array(0, 0, 0, 0) If Res.Range("A1").CurrentRegion.Rows.Count > 2 Then Res.Range("A1").CurrentRegion.Offset(2). _ Resize(Res.Range("A1").CurrentRegion.Rows.Count - 2).Clear End If If Res.Cells(2, "H") = vbNullString Then Exit Sub For Each Sh In Sheets If Sh.Name <> "Result" Then Sh.Range("A3:J1000"). _ Interior.ColorIndex = xlNone Set F_rg = Sh.Range("B:B"). _ Find(Res.Cells(2, "H"), lookat:=1) If Not F_rg Is Nothing Then ro1 = F_rg.Row: ro2 = ro1 Do Sh.Cells(ro2, 1).Resize(, 10). _ Interior.ColorIndex = 35 Ar(0) = Ar(0) + Val(Sh.Cells(ro2, 5)) Ar(1) = Ar(1) + Val(Sh.Cells(ro2, 6)) Ar(2) = Ar(2) + Val(Sh.Cells(ro2, 9)) Ar(3) = Ar(3) + Val(Sh.Cells(ro2, 10)) Set F_rg = Sh.Range("B:B").FindNext(F_rg) ro2 = F_rg.Row If ro1 = ro2 Then Exit Do Loop End If End If Next Sh With Res.Cells(3, 1) .Value = 1 .Offset(, 1) = Res.Cells(2, "H") .Offset(, 2).Resize(, UBound(Ar) + 1) = Ar With .Resize(, UBound(Ar) + 3) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .InsertIndent 1 .Interior.ColorIndex = 35 End With End With End Sub بالنسبة لكل الاسماء Sub Data_Sum_ALL() Dim Res As Worksheet Dim Sh As Worksheet Dim ro1%, ro2%, K% Dim F_rg As Range Dim Ar Dim OBJ As Object, ky Dim m%, t% Set OBJ = CreateObject("Scripting.Dictionary") Set Res = Sheets("Result") If Res.Range("A1").CurrentRegion.Rows.Count > 2 Then Res.Range("A1").CurrentRegion.Offset(2). _ Resize(Res.Range("A1").CurrentRegion.Rows.Count - 2).Clear End If For Each Sh In Sheets If Sh.Name <> "Result" Then m = 3 Do Until Sh.Cells(m, 2) = vbNullString OBJ(Sh.Cells(m, 2).Value) = vbNullString m = m + 1 Loop End If Next Sh Ar = Array(0, 0, 0, 0) If OBJ.Count Then t = 3 For Each ky In OBJ.keys For Each Sh In Sheets If Sh.Name <> "Result" Then Set F_rg = Sh.Range("B:B").Find(ky, lookat:=1) If Not F_rg Is Nothing Then '+++++++++++++++++++++++ ro1 = F_rg.Row: ro2 = ro1 Do Ar(0) = Ar(0) + Val(Sh.Cells(ro2, 5)) Ar(1) = Ar(1) + Val(Sh.Cells(ro2, 6)) Ar(2) = Ar(2) + Val(Sh.Cells(ro2, 9)) Ar(3) = Ar(3) + Val(Sh.Cells(ro2, 10)) Set F_rg = Sh.Range("B:B").FindNext(F_rg) ro2 = F_rg.Row If ro1 = ro2 Then Exit Do Loop '++++++++++++++++++++++++++ End If 'F_rg End If 'Sh Next Sh Res.Cells(t, 2) = ky Res.Cells(t, 3).Resize(, UBound(Ar) + 1) = Ar Ar = Array(0, 0, 0, 0) t = t + 1 Next ky With Res.Range("A3").Resize(t - 3, 6) .Columns(1).Value = _ Evaluate("Row(1:" & t - 3 & ")") .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .InsertIndent 1 .Interior.ColorIndex = 35 End With End If 'dic.count End Sub الملف مرفق Ihab_ALL.xlsm

كنت أود عمل ذلك لكن حصرتك ما اقتنعت بالكود الذي كتبته لك في المشاركة السابقة

ممتاز لكن الاخ بريد ان يكون عدد الصفحات غير محصور بــ 2 فقط

لا تحكم على شيء دون ان تتأكد لا حظ عبد الكريم سلام (عدد الساعات لا تتم حسابها) لانك لم تضعها في الجدول في الصفحة Result في الصفحة الأولى : 1- من C7 الى J7 في كل خلية 1 2- من C10 الى J10 في كل خلية 1 في الصفحة الثّانية : 1- من C6 الى J6 في كل خلية 1 2- من C10 الى J10 في كل خلية 1 3- من C13 الى J13 في كل خلية 1 المحموع العام في كل حلية 5 وهذا ما تجده في الصفحة Result Ihab_summation_1.xlsm

جرب هذا الماكرو (حتى لو تكرر الاسم في نفس الصفحة يقوم الماكرو بايجاده مع تلوينه) مثلاً "كريم عفيفى" Sub Data_Sum_1() Dim Res As Worksheet Dim sh As Worksheet Dim ro1%, ro2%, K% Dim F_rg As Range Dim Ar Set Res = Sheets("Result") Ar = Array(0, 0, 0, 0, 0, 0, 0, 0) Res.Range("A3:I3").ClearContents If Res.Cells(1, "K") = vbNullString Then Exit Sub For Each sh In Sheets If sh.Name <> "Result" Then sh.Range("A3:J1000"). _ Interior.ColorIndex = xlNone Set F_rg = sh.Range("A:A"). _ Find(Res.Cells(1, "K"), lookat:=1) If Not F_rg Is Nothing Then ro1 = F_rg.Row: ro2 = ro1 Do sh.Cells(ro2, 1).Resize(, 10). _ Interior.ColorIndex = 35 For K = LBound(Ar) To UBound(Ar) Ar(K) = Ar(K) + Val(sh.Cells(ro2, 3).Offset(, K)) Next Set F_rg = sh.Range("A:A").FindNext(F_rg) ro2 = F_rg.Row If ro1 = ro2 Then Exit Do Loop End If End If Next sh With Res.Cells(3, 1) .Value = Res.Cells(1, "K") .Offset(, 1).Resize(, UBound(Ar) + 1) = Ar End With End Sub الملف مرفق Ihab_summation.xlsm

فقط تختار الاسم ثم تضغط على الزر Run

شاهد هذا الفيديو https://www.youtube.com/watch?v=vk94OfXI9GM&ab_channel=TechnicalSupportOnline

تم تنزيل الملف مرة ثانية والتعديل على الكود 1- عند طباعة الفاتورة يتغير لونها و يدرج في العامود K تاريخ الطياعة 2- اذا اردت طباعتها مرة احرى تحصل على رسالة تفيد انه تم طباعتها مسيقاً والرسالة تعطيك حيار الطباعة مرة اخرى او لا 3- عندما تريد (عند نهاية الشهر مثلاً) اضغط الزر New Month لتمسح التواريخ و ترجع الألوان الى طبيعتها Option Explicit Dim S As Worksheet Dim B As Worksheet Dim last%, i%, Nb% Dim dic As Object Dim Mon_array Dim Itm Dim rg As Range Dim Answer As Byte '++++++++++++++++++ 'Other macro to Ptint One fatura Sub Fatura_Only_One() Set S = Sheets("Source") Set B = Sheets("By_one") Set dic = CreateObject("Scripting.Dictionary") last = S.Cells(Rows.Count, 1).End(3).Row For i = 4 To last If Not IsEmpty(S.Cells(i, 2)) Then Mon_array = Application.Transpose _ (S.Cells(i, 1).Resize(, 9)) Mon_array = Join(Application.Transpose(Mon_array), "*") dic(dic.Count) = Mon_array End If Next If dic.Count Then If Val(B.Range("H5")) <= 0 Or _ Val(B.Range("H5")) > dic.Count Then B.Range("H5") = 1 Else B.Range("H5") = Int(B.Range("H5")) End If Nb = Int(B.Range("H5")) - 1 B.Range("E6").Resize(9) = _ Application.Transpose(Split(dic.Items()(Nb), "*")) Set rg = S.Range("B1:B" & last).Find(B.Range("E7"), lookat:=1) If Not rg Is Nothing Then S.Cells(rg.Row, 1).Resize(, 9).Interior.ColorIndex = 35 End If If S.Cells(rg.Row, "K") Like "Printed On:*" Then Answer = MsgBox("هذه الفاتورة تمت طباعتها مسبقاُ" & Chr(10) & _ "هل تريد الطباعة مرة ثانية", 1048644) If Answer <> 6 Then GoTo End_me End If S.Cells(rg.Row, "K") = "Printed On:" & Date '========================== B.PrintPreview ' '======================== End If End_me: Set dic = Nothing End Sub الملف مرفق Bab Salam_Super.xlsm

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

هذه المعادلة في A2 مع (Ctrl+Shift+Enter) =IFERROR(INDEX($H$5:$Q$5,SMALL(IF(INDEX($H$6:$Q$11,MATCH(A$1,$G$6:$G$11,0),)<>0,COLUMN($H$5:$Q$5)-COLUMN($H$5)+1),ROWS(A$2:A2))),"") الملف مرفق Moustfa.xlsx

يمكن استعمال معادلة واحدة في الخلية B6 وسحبها يميناُ ( 4 أعمدة) ونزولاُ (20صف) =IFERROR(INDEX(INDIRECT($B$4),$A6,COLUMNS($A$1:A1)),"")

تم التعديل على الكود 1- تضع في الخلية R6 القيمة Sell 2- تضع في الخلية R7 القيمة Wait 3- تضع في الخلية R8 القيمة Cllose و هكذا كلما غيرت شيئا في R6 أو R7 أو R8 تتغير النتائج كما في الصورة Sub Auto_sum() Dim H% With Sheets("Sheet2") H = .Cells(Rows.Count, "H").End(3).Row .Range("k2:k" & H).Formula = _ "=IF(C2="""","""",IF(AND(C2<=0,D2>=0,F2<=0,G2<=0,H2<=-15,M2<=-13),$R$6,""""))" .Range("L2:L" & H).Formula = _ "=IF(C2="""","""",IF(AND(F2<=0,G2<=0,H2<=-15,M2<=-8),$R$7,$R$8))" .Range("N2:N" & H).Formula = _ "=IF(C2="""","""",IF(AND(F2>=0,G2>=0,H2>=15,M2>=8),$R$7,$R$8))" End With End Sub الصورة

جرب هذا الكود (لتغيير عدد كلمات السر استبدل في الكود الرقم 19 الى اي رقم تريده) Option Explicit Sub My_Paws() Dim col As Object Dim i%, m, x, Bol, s, k% Const How_many_Pass = 19 Set col = New Collection For i = 64 To 90: col.Add Chr(i): Next For i = 97 To 122: col.Add Chr(i): Next For i = 0 To 9: col.Add i: Next col.Add "*" m = 2 x = col.Count For i = 1 To How_many_Pass For k = 1 To 12 Bol = Int(Rnd() * (x - 1)) + 1 s = s & col(Bol) Next k Cells(m, "G") = s m = m + 1: s = "" Next End Sub الملف مرفق alexandrien.xlsm

جرب هذا الكود Option Explicit Sub extract_Data() Dim Source_sheet As Worksheet Dim Target_sheet As Worksheet Dim Ism, R_to_copy As Range Dim Find_rg As Range Set Source_sheet = Sheets("sheet1") Set Target_sheet = Sheets("sheet2") If Target_sheet.Range("B4") = "" Then Target_sheet.Range("B4") = "خالد" End If Ism = Target_sheet.Range("B4") Set Find_rg = Source_sheet.Cells.Find(Ism, lookat:=1) If Not Find_rg Is Nothing Then Set R_to_copy = Find_rg.Offset(2).Resize(20, 4) Target_sheet.Range("B6").Resize(20, 4).Value = _ R_to_copy.Value End If End Sub الملف مرفق Khaled.xlsm

جيث انك لم ترفع ملف للمعاينة يمكن تجربة هذا الملف Date_function.xlsx

في هذه الحالة لا أفهم ما هي الحاجة للكود ( اذا كنت تريد المعادلة وليس نتيحتها اكتب المعادلات فوراً في الخلابا) طالما الاكسل يفوم وحده بحساب المعادلات مع كل تغيير في الخلايا