نجوم المشاركات

رائع جدا @د.كاف يار

تفضل هذا المثال اخي الكريم طريقة بالاستعلام و طريقة بالكود حساب التقاعد.accdb

عليك السلام ورحمة الله وبركاته تفضل 1.xlsx

اخي العزيز حسين أرى انه لا ضرورة لحلقة تكرارية من ثاني صف في العامود C الى ان تجد ما نفتش عنه (ممكن ان يكون الرقم في الصف رقم 5000 مثلاً اذا كانت البيانات كثيرة) يكفي ان نستعمل دالة Find في VBA لايجاد الرقم بسرعة اكبر بكثير ، لان هذه الدالة تضع يدها على الصف المطلوب مباشرة باستعمال هذا الماكرو Sub Find_Me() Dim rng, r% On Error Resume Next With Sheets("Sheet1") .Range("H2") = vbNullString If .Range("G2") = "" Then End Set rng = .Range("c2", Range("c1").End(4)) r = rng.Find(.Range("G2"), lookat:=1).Row If r > 0 Then .Range("H2") = .Cells(r, "D") End With End Sub

تفضل اختر من الكومبوبوكس واضغط زر بحث تقسيط .xlsm

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

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

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

اليك هذا الملف لعله يفى بالمطلوب افتح ملف kawkab.rar تجد اربع ملفات kawkap,kawkap1,kawkap2,kawkap3 ضعهم داخل فولدر وافتح الملف الرئيسى kawkap واضغط على ذر import dيتم جلب البيانات من الملفات الثلاث الاخرى دون فتحها ويمكنك زيادة الملفات كما تريد بتكرار الكود وتعديل اسم الملف واسم الشيت فى الكود kawkap.rar

جزاكم الله خيرا أخي الكريم أ / علي @Ali Mohamed Ali و نفع بعلمكم و علمكم ما ينفع- آمين

تفضل هذا المقترح مندوبي المبيعات.accdb

Me.HdihSr = Nz(DSum("[PriceSB]", "00KashfTodayRsdCkdm","(Movement ='هدية' or Movement ='تالف' or Movement ='مفقود')") لم اجرب الكود

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

هذا المامرو ربما يفي بالغرض Option Explicit Sub ConvertFormulasToValues() Dim r As Long Dim i As Byte r = Range("A" & Rows.Count).End(xlUp).Row Dim st1$: st1 = "=100" Dim st2$: st2 = "=IF(C8=""ناصر"",666.65,120.25)" Dim st3$: st3 = "=IF(C8=""سليم"",""ممتاز"","""")" Dim st4$: st4 = "=IF(D8=""اوفسينا"",""المنتدى الاول"","""")" With Cells(8, 5).Resize(r) .Formula = st1 .Offset(, 1).Formula = st2 .Offset(, 2).Formula = st3 .Offset(, 3).Formula = st4 .Resize(, 4).Value = .Resize(, 4).Value End With End Su

ممكن هذا المثال يبسط الأمور Option Explicit Sub Fast_macro() Dim La#: La = Cells(Rows.Count, 1).End(3).Row With Range("D2").Resize(La - 1) .Value = vbNullString .Formula = "=SUM(A2:B2)" .Value = .Value End With End Sub الملف مرفق value.value.xlsm

استادي سليم الف الف تحية اخي لا يمكن لي كتابة مثل هذا الماكرو مازلت مبتدءا في الاكسيل ومعرفتي في الميدان محدودة ، انتم اساتذتنا تعلمنا منكم وما زلنا ماكرو رائع كعادتك دائما وابدا نستمتع بأعمالك جزاك الله خيرا وحفظك وزادك علما . تحياتي لجميع الاساتدة في المنتدى اخوكم في الله حسين مامون من المغرب

فقط غيرت طريقه الربط من واحد الى 2 شوف الصورة

جرب هذا تعديل استعلام.accdb

تفضل التعديل هذا اخي الكريم المبيعات.rar

تم معالجة الامر (سم المندوب) وهذه المرة بـــ معادلة بسيطة تم ادراجها في نفس الكود (ولا لزوم لتكرار التاريخ حيث ان البيانات بين تاريخ واخر بفصلها صف فارغ) الكود الجديد Option Explicit Sub Give_data1() Rem =====>>> Created By Salim Hasbaya On 1/9/2019 Dim Dict As Object Dim st, ff% Dim Ro%, x%, t%, arr Dim Itm, i%: i = 2 Dim K, Ky, xx% ': xx = 3 Dim SA As Worksheet: Set SA = Sheets("Salim") Dim DA As Worksheet: Set DA = Sheets("data") Dim My_col As New Collection Dim My_col2 As New Collection 'For remove the Contents Of the sheet "Salim" Please remove _ the "'" from the next line 'SA.Range("a3").Resize(10000, 5).ClearContents xx = SA.Cells(Rows.Count, "c").End(3).Row xx = IIf(xx = 2, 3, xx + 2) Set Dict = CreateObject("SCRIPTING.DICTIONARY") Ro = DA.Cells(Rows.Count, "G").End(3).Row For i = 2 To Ro On Error Resume Next My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " " Next For i = 1 To My_col.Count For x = 2 To Ro If DA.Cells(x, "G") = My_col(i) Then K = DA.Cells(x, "L") Itm = Application.CountIf(DA.Range("E2:L" & x), DA.Range("L" & x)) If Not Dict.Exists(My_col(i)) And Itm = 1 Then Dict.Add My_col(i), K Else Dict(My_col(i)) = Dict(My_col(i)) & "," & K End If End If Next x SA.Range("A" & xx) = My_col(i) For Each Ky In Dict.keys arr = Split(Dict(Ky), ",") For ff = 0 To UBound(arr) On Error Resume Next My_col2.Add arr(ff), arr(ff) Next ff If My_col2(1) = "" Then My_col2.Remove (1) On Error GoTo 0 Erase arr ReDim arr(1 To My_col2.Count) For ff = 1 To My_col2.Count arr(ff) = My_col2(ff) Next ff t = UBound(arr) If t >= 1 Then SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _ Application.Transpose(arr) End If xx = SA.Cells(Rows.Count, "c").End(3).Row + 2 Dict.RemoveAll: Erase arr: Set My_col2 = New Collection Next Ky Next 'For remove the Contents Of the sheet "Data" Please remove _ the "'" from the next line 'kiLL_data With SA.Range("d3").Resize(xx - 2) .Formula = "=IF(c3="""","""",INDEX(Data!$H$2:$H$500,MATCH($C3,Data!$L$2:$L$500,0)))" .Value = .Value End With Dict.RemoveAll: Erase arr: Set My_col2 = Nothing Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing End Sub '++++++++++++++++++++++++++++++++++++++ Sub kiLL_data() Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents End Sub الملف من جديد Show Sales_salim_ 2019_Super.xlsm

هنا

العامود الاصفر في صفحة Salim من هذا الملف No_dup _by_formula.xlsm

هذا الكود يفي بالغرض ان شاء الله (تم تغيير اسماء الصفحات لنسخ الكود بشكل جيد وعدم الوقوع في مشاكل اللغة حيث تظهر حروف غير معروفة عند البعض) Option Explicit Sub AnyThing() Dim lastrow_1 As Long, counter As Long Dim lastrow_2 As Long, key As Variant Dim sh1 As Worksheet, sh2 As Worksheet Dim rng1, rng2 As Range, p As Variant Dim dict As Object Set sh1 = Sheets("SH1") Set sh2 = Sheets("SH2") sh2.Range("I3").Resize(1000, 3).ClearContents lastrow_1 = sh1.Cells(sh1.Rows.Count, "B").End(3).Row lastrow_2 = sh1.Cells(sh2.Rows.Count, "B").End(3).Row Set rng1 = sh1.Range("A3:D" & lastrow_1) Set rng2 = sh2.Range("A3:D" & lastrow_2) Set dict = CreateObject("Scripting.Dictionary") For Each p In rng1.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '=============================== For Each p In rng2.Columns(2).Cells If Not dict.Exists(p.Value & "," & p.Offset(, 1)) Then dict.Add p.Value & "," & p.Offset(, 1), p.Offset(, 2) Else dict(p.Value & "," & p.Offset(, 1)) = _ dict(p.Value & "," & p.Offset(, 1)) + p.Offset(, 2) End If Next p '============================== counter = 2 With sh2 For Each key In dict.Keys counter = counter + 1 .Cells(counter, "I").Resize(1, 2) = Split(key, ",") .Cells(counter, "K") = dict(key) Next key End With dict.RemoveAll: Set dict = Nothing Set sh1 = Nothing: Set sh2 = Nothing Set rng1 = Nothing: Set rng2 = Nothing End Sub الملف المرفق Total.xlsm

جرب هذا الماكرو Option Explicit Sub Unique_BY_Dictionary() Rem ====>> Created By Salim Hasbaya On 30/8/2019 If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim i% Dim obj As Object Range("D2", Range("D1").End(4)).ClearContents Range("e2").ClearContents Set obj = CreateObject("scripting.dictionary") obj.CompareMode = 1 Dim last_ro: last_ro = Cells(Rows.Count, "B").End(3).Row With obj For i = 2 To last_ro If Application.CountIf(Range("H2:H4"), Range("B" & i)) = 0 Then .Item(Range("B" & i).Value) = "" End If Next Range("d2").Resize(.Count) = _ Application.Transpose(.keys) Range("e2") = .Count End With End Sub الملف مرفق No_dup.xlsm

وعليكم السلام-تفضل لك ما طلبت حساب اجماليات السلع.xls

تفضل اخى الكريم -المشكلة كانت فى ملفك انت كانت التنسيقات غير منضبطة شركة تيما الحديثة (1).xlsx

تفضل هذا الرابط هيفيدك https://www.officena.net/ib/topic/88238-طريقة-تحديد-خلايا-معينة-حسب-مجموع-معين/?tab=comments#comment-556938

وعليكم السلام تفضل بالمعادلات شركة تيما الحديثة.xlsx

تفضل الحل بالمعادلات بيانات الموظفين.xlsx

أهلا بك اخى الكريم فى المنتدى تفضل تم الحل بالتنسيق 55.xlsx او يمكنك بهذه المعادلة اذا كنت تريد ظهور الأرقام بعمود اخر ويمكنك سحب المعادلة للأسفل =CONCATENATE("+966",$A1)

وعليكم السلام تفضل الترحيل 2020.xlsm

وعليكم السلام تفضل past link.xlsx

تفضل RAJHI 22018.xlsx

جزاك الله كل خير موضوعات مهمة وشيقة

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

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

رجاءا اخى hitech دائما وابدا اجعل عنوان مشاركتك مطابق ودليل على ما تطلب حتى يكون مرجعا لغيرك مستقبلا بمعنى ان يكون عنوان هذه المشاركة مثلا فصل الوقت عن التاريخ فى خلايا مستقلة وليس كما قلت ارجو المساعدة ضرورى -فهذا من قواعد المنتدى ولكى يتم المساعدة من قبل الأساتذة تفضل فصل الوقت عن التاريخ.xlsx

تفضل VLookUP.xlsm

أخى الكريم منذر هذا ملف اخونا واستاذنا الأهلاوى ليس لى أنا بارك الله فيك

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

هذه محاولة ادق بالمعادلات 2.xlsm

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

وعليكم السلام تفضل المصنف1.xlsm

اخى منذر المرفق تمام وليس به اى مشاكل فى التحميل عليك بتحديث ملف فك الضغط لديك مثل winrar

وعليكم السلام استاذ محمود عمل ممتاز وشرح وافى جعله الله فى ميزان حسناتك عودا حميدا وحشتنا كتير

نفضل DIFF period-فرق السنوات والشهور والأيام على ثلاثة خلايا.xlsx

لا يوجد شخص بعينه ولكن يمكنك مشاهدة معظم الفيديوهات واذا ارتحت لطريقة شخص ما يمكنك متابعته

تفضل DIFF period-فرق السنوات والشهور والأيام على ثلاثة خلايا.xlsx

أحسنت استاذ مجدى عمل رائع جعله الله فى ميزان حسناتك ورحم والديك وغفر الله لهما

وعليكم السلام تفضل find date 0000.xlsm