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

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

وعليكم السلام كان عليك لزاما استخدام خاصية البحث بالمنتدى قبل رفع مشاركتك فقد تم تناول هذا الموضوع مرات عدة ومنها ربط الصورة بالإسم وهذا فيديو أيضاً للشرح ويمكنك تحميل ملف الشرح أسفل الفيديو استدعاء صورة الموظف من مجلد بالاكسيل Vlookup Picture VBA بعد كل هذا فقمت بحل طلبك بدالة معرفة ... فيمكنك وضع هذه المعادلة ابتداءا من الخلية B2 سحباً للأسفل =IF(A2="","",VLOOK_Pic1($A2)) وهذا هو كود الدالة Function VLOOK_Pic1(PicName) Dim CurrentCel As Range, Pic As Shape PicName = PicName: MyPath = ThisWorkbook.Path & "\Data\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png") Set CurrentCel = Application.Caller Set CurrentCel = CurrentCel.MergeArea For Each Pic In ActiveSheet.Shapes If Pic.Type = msoLinkedPicture Then If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then Pic.Delete Exit For End If End If Next For X = LBound(ChkPic) To UBound(ChkPic) If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): VLOOK_Pic1 = "" Exit For Else VLOOK_Pic1 = "لا توجد صورة" End If Next End Function khalid.rar

السلام عليكم جرب المرفق... Classeur1.xlsx

تفضل اخي الكريم Dim frm As Form DoCmd.OpenForm "frm3", acNormal, , , , acHidden Set frm = Forms("frm3") DoCmd.OpenForm frm.Name Debug.Print frm.Name Set frm = Nothing تحياتي

استبدل السطر التالي newpathANDname = newpathANDname & "\" & Me.Animal_ID بهذا newpathANDname = newpathANDname تحياتي

يمكنك استخدام هذا الكود -فقد تم ضبط الملف و عمل قائمة منسدلة ديناميكية وبدون فراغات لأسماء العملاء ... كما تم ادخال معادلة أيضاً لمعرفة طبيعة كل صنف هل بالكيلو ام بالحبة Sub TARHEEL() If IsEmpty(Cells(5, 2)) Then MsgBox "يــرجــى إدخــال رقــم الفــاتــورة" Exit Sub End If Dim R As Integer Dim xNewR As Integer For R = 14 To 23 If IsEmpty(Cells(R, 2)) Then Exit Sub xNewR = Sheets("SLS").Cells(1, 1).CurrentRegion.Rows.Count + 1 Sheets("SLS").Cells(xNewR, 1) = Cells(5, 2) Sheets("SLS").Cells(xNewR, 2) = Cells(5, 6) Sheets("SLS").Cells(xNewR, 3) = Cells(7, 3) Sheets("SLS").Cells(xNewR, 4) = Cells(8, 3) Sheets("SLS").Cells(xNewR, 5) = Cells(R, 1) Sheets("SLS").Cells(xNewR, 6) = Cells(R, 2) Sheets("SLS").Cells(xNewR, 7) = Cells(R, 3) Sheets("SLS").Cells(xNewR, 8) = Cells(R, 4) Sheets("SLS").Cells(xNewR, 9) = Cells(R, 5) Sheets("SLS").Cells(xNewR, 10) = Cells(R, 6) Cells(R, 2) = "" Cells(R, 4) = "" Cells(R, 5) = "" Next Do Loop Cells(5, 2) = "" End Sub كود ترحيل الفاتورة.xlsm

على حسب ما فهمت اعتقد هذا ما تريدة جرب هذه المعادلة =IF(SUMPRODUCT((E2:Q2=A2)*(1));A2;"") المصنف1.xlsx

طبعاً بعد اذن استاذنا عبد الرحيم ... ولإثراء الحل - تفضل على الرغم من تكرار هذه الموضوعات بالمنتدى 19.xlsm

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 لجلب الاسماء المسجلين في شيت "الرحلات – المعتمرين"

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم تم تعديل اسم مربع تحرير وسرد الى Combobox1 وتم تعديل النموذج الفرعي الى subform1 ثم استخدمنا الكود التالي Private Sub Combobox1_Click() If Me.Combobox1.Value = "نعم" Then Me.subform1.Form.AllowEdits = True Me.subform1.Form.AllowAdditions = True Else If Me.Combobox1.Value = "لا" Then Me.subform1.Form.AllowEdits = False Me.subform1.Form.AllowAdditions = False End If End If End Sub Private Sub Form_Current() Combobox1_Click End Sub Database3_3.rar تحياتي

ان شاء الله تستفاد من هذه المعادلة توريد شهر.xlsx

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

وعليكم السلام ورحمة الله وبركاته أخى الكريم برجاء أن يتسع صدركم لكثرة ما أطلب واعتذر عن عدم توصيل المطلوب لشخصكم الكريم على النحو الأفضل فرجاءا التماس العذر لى فى هذا الشأن ومن جانب أخر أشكر لكم أهتمامكم فى العمل على هذا الملف وإن كان هذا ليس بجديد على أهل اليمن الكرام الأفاضل نفعنا الله بعلمكم وبارك لنا فى عمركم وغفر الله لنا ولكم أمين يارب العالمين ... وبعد هل بالإمكان أخى الكريم ربط أنصبة المعلمين بالمدون قرين كل فئة منهم والملونة باللون الأحمر مثل معلم خبير 16 حصة ومعلم أول أ بـ 16 حصة ومعلم أول بـ 17 حصة ومعلم بـ 18 حصة ومعلم مساعد بـ 18 حصة وكبير معلمين بـ 14 حصة بدلا من أرتباطهم بعمود النصاب AA حتى يتسنى استخراج نفس النتائج الموجودة بأعمدة الحصص والمعلمين كما أنه سيكون متاح عند الرغبة فى أن توزيع الأنصبة بالتساوى ( 14 ) حصة للجميع سيتم تعديلها مع فئات المعلمين المختلفة حسب الرغبة فى ذلك ومرفق الملف المراد أرتباط الأنصبة به وهو الملون باللون الأحمر حسب عدد حصص المقررة لكل معلم الموجودة بين القوسين قرين كل مسمى (معلم مساعد ، معلم ، معلم أول ، معلم أول أ ، معلم خبير ، كبير معلمين ) بدلا من الارتباط بالعمود الملون باللون البرتقالى (النصاب) حيث يمكننى بعد ذلك التعديل فى عدد حصص كل فئة على حدة واعتذر عن الإطالة وجزاكم الله عنا خير الجزاء وأى استفسار إن شاء الله سأكون عند حسن الظن تحياتى لحضرتك وللقائمين على منتدى أوفيسنا بيان العجز والزيادة للعام 2021 (1).xlsx

السلام عليكم ورحمة الله وبركاته تم تعديل معادلة عمودي العجز والزيادة بيان العجز والزيادة للعام 2021.xlsx

وعليكم السلام ورحمة الله وبركاتة Database5.rar

لك ما تريد Ashraf.xlsx

تم معالجة الجرء الأول لكن الجزء الثاني فيه غموض (ربما بسبب الكتابة ياللغة العربية والأحنبية معاً بحيث لا تبدو المعطيات مفهومة) اضغط الزر User لاظهار اليوزر test RJS .xlsm

See This video https://www.youtube.com/watch?v=oTjUuFZNmy8&ab_channel=TubeMint

اخي الكريم اين المشكلة مع الكود كل ما عليك هو كتابة الرقم في الخلية a5 وسيقوم بالتصفية بناء على العمود الخامس التي به الارقام وفي حالة مسح البيان سيعرض البيانات بالكامل نزل الملف الذي ارفقته وطبق ما قلته لك ونصيحتي لك يجب ان تتعلم كيفية التعامل مع الاكواد انا لاا طلب منك ان تكون مبرمج ولكن تعلم كيفية تتطويع الكود وتعديله بناء على احتياجاتك وعندما تتقن ذلك ستترك المعادلات والعمل بشكل يدوي تحياتي

بارك الله فيك استاذ أحمد وزادك الله من فضله

انا شخصياً كنت زيك مفتكر ان الاكسل مش اكثر من جدول وشوية كده هوو معادلات ضرب وجمع... إلى ان غطست في هذا البحر (لا بل المحيط الهائل) و ما زلت بكل تواضع لا اعرف (حسب تقديري) اكثر من 10% من المعلومات حول هذا البرنامج كل شيء اعرفه تم اكتسابه 1-بواسطة مشاهدة الفيديوهات (لم اتعلمه اكاديمياً في معهد أو جامعة) 2- التجارب التي أقوم بها على الاكسل يعجبني قول احد الشّعراء قل لمن يدّعي بالعلم معرفةً عرفت شيئاً و غابت عنك أشياءُ

السلام عليكم ورحمة الله وبركاته استكمالا لسلسلة شرح الجمل الشرطية سنستحدث سلسلة اخرى تتعلق بكيفية استخدام الخلايا في ال vba وكان من المفروض البدء بها قبل شرح الجمل الشرطية لكونها تعتمد عليها في بعض الجوانب وسيتم تناول ثلاثة مواضيع بالتناوب وهي : 1. استخدام جمل ال range 2. استخدام جمل ال cells 3. استخدام جمل ال offset وسنبدأ بالموضوع الاول ...حيث هناك مرفق تم فيه شرح الكيفية في الاستخدام الموضوع باجتهاد شخصي وقد يحتمل الصواب والخطأ وقد يحتمل النسيان فان كنت قد أصبت فالحمد لله وانت كنت قد اخطأت فذلك يعلمني وان كنت قد نسيت فجل من لا ينسى او ان اكون قد اغفلت بعض الجوانب التي لم اضعها في الحسبان وهذه دعوة مفتوحة للجميع بالمشاركة في هذا الموضوع حتى يكون موضوع هادف وكامل ومفيد ان شاء الله اخوكم عماد الحسامي hosami range.rar