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

اللغة العربية دائما ما تسبب مشاكل في الاكواد (انصح بعدم استعمالها) لذلك تم تغيير اسماء الازرار الى SHP_1 و SHP_2 الكود Sub Button02() Dim arr(1), i% arr(0) = "SHP_1": arr(1) = "SHP_2" For i = 0 To 1 ActiveSheet.Shapes.Range(Array(arr(i))).Select ' +++++++++++++++++++++++++++++ If Selection.Text = "Show" Then Rows("5:20").EntireRow.Hidden = False With Selection .Font.ColorIndex = 2 .Text = "Hide" .ShapeRange.Fill.ForeColor.RGB = _ RGB(192, 0, 0) End With Else Rows("5:20").EntireRow.Hidden = True With Selection .Font.ColorIndex = 6 .Text = "Show" .ShapeRange.Fill.ForeColor.RGB = _ RGB(0, 0, 255) End With End If '++++++++++++++++++++++++++++++++ Next [A1].Select End Sub الملف مرفق Double_but.xlsm

بعد اذن استاذنا سليم ولإثراء الموضوع ,,فهذا حل ايضا بمعادلة المصفوفة =IFERROR(INDEX(ورقة1!$C:$C,SMALL(IF(ورقة1!$B:$B=A$2,ROW(A$2:A$5000)-ROW(A$2)+1),ROWS($A$5:A5))),"") المشاريع1.xlsx

جرب هذا الملف الكود Option Explicit Sub transfer_data() Dim S1 As Worksheet, S2 As Worksheet Dim Rg1 As Range Set S1 = Sheets("ورقة1"): Set S2 = Sheets("ورقة2") If S2.Range("A1").CurrentRegion.Rows.Count > 1 Then _ S2.Range("A1").CurrentRegion.Offset(1) _ .Resize(S2.Range("A1").CurrentRegion.Rows.Count - 1).Clear Set Rg1 = S1.Range("A1").CurrentRegion If Rg1.Rows.Count = 1 Then Exit Sub Set Rg1 = Rg1.Offset(1).Resize(Rg1.Rows.Count - 1) Rg1.Columns(2).Copy S2.Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True Application.CutCopyMode = False With S2.Range("A1").CurrentRegion.Rows(2) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .Interior.ColorIndex = 19: .Cells(1, 1).Select End With End Sub الملف مرفق Mashri3.xlsm

بعد اذن استاد سليم واثراء للموضوع Private Sub CommandButton1_Click() Dim i As Worksheet, myLoop As Long For Each i In Worksheets With i For myLoop = 2 To 104 If .Cells(myLoop, "j").Value = "سدد" Then .Rows(myLoop).Hidden = False Else .Rows(myLoop).Hidden = True End If Next myLoop End With Next i End Sub Private Sub CommandButton2_Click() Dim i As Worksheet, myLoop As Long For Each i In Worksheets With i For myLoop = 2 To 104 If .Cells(myLoop, "j").Value = "سدد" Then .Rows(myLoop).Hidden = True Else .Rows(myLoop).Hidden = False End If Next myLoop End With Next i End Sub اظهار واخفاء صفوف.xlsm

منا ومنكم سائر الأعمال ان شاء الله يمكنك هذا بمعادلة المصفوفة =IFERROR(INDEX(Data!$A:$A,SMALL(IF(Data!$C:$C=$C$1,ROW(A$2:A$5000)-ROW(A$2)+1),ROWS($A$3:A3))),"") Data_HR2.xls

تفضل إإيجاد المكرر و الاسماء و ترحيل الى الاعمدة d :e و ترتيب الاسماء أبجديا. مقارنة.xlsm

برنامج يصلح لادارة عيادات الاسنان والعلاج الطبعى بسيط وسهل الاستخدام بدون باسورد طبيب الاسنان او العلاج الطبيعى.xlsm

سهلة ، بدل ان تعمل كود التأكد في VBE ، تقدر تعمله في ماكرو 🙂 شو الحقل الاساسي في النموذج الفرعي ، والذي يجب ان يكون فيه قيمة ؟ جعفر

بأي طريقة عملت ، تحتاج الى كود بطريقة او اخرى ، او تغيير اعدادات حقل في جدول ، بحيث تمنع كونه خالي من قيمة. ولكن السؤال ، لماذا هذا الشرط ؟ جعفر

هلا اخي جرب الكود من المهم لكي يعمل الكود ان يكن التسلسل صحيح ... اذا كان اخر دفعة لكارت هو رقم 4 فدفعة الجديدة يجب ان تكن 5 db2card_UPDATED2.mdb

لقد قمت بحذف الملف من حهازي رجاء ارفع ملفاً جديداً يحتوي على قليل من البيانات العشوائية مع الكلمات التي تريدها ان تختفي صفوفها ( في كل صفحة 10 صفوف لا أكثر)

السلام عليكم محاولة الحل باستعمال الدالة OFFSET بدلا من الدالة VLOOKUP بمعادلات صفيف... 2 (7).xlsx

ربنا يسعد قلبك ويكرمك ويبارك لك اللهم امين يارب استاذ سليم حبيبي يعجز لساني عن شكرك أكرمك الله حبيبي يا استاذنا.

تفضل اخي ابو الحسن Sheet_Name.xlsm

هلا اخي جرب المرفق db2card_UPDATED.mdb

السلام عليكم انا رأيي انك لست بحاجة لعمل عمود للمتبقي في الجدول الفرعي واذا كانت هذه الحسبة شهرية او لفترة محددة فهنا يتأكد كلامي اعلاه الحل حسب ما اراه ولا بأس من الاستئناس بآراء الاخوة الاعزاء هو ان يظهر المتبقي في حقل غير منضم بجانب الكمية المخصصة في النموذج الرئيس العملية تتم بجمع الكمية للمعرف المحدد حسب الفترة وتطرح من الكمية المخصصة عند ادخال وزن جديد تتم المقارنة بين الرقم المدخل وبين الكمية المتبقية

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

وعليكم السلام ورحمة الله وبركاته 🙂 سؤال : اذا يوجد ربط بين النموذج الرئيسي والنموذج الفرعي عن طريق الحقل ID ، لما يعمل النموذج الفرعي سجل جديد ، اي رقم ID يأخذ ؟ هذه المعضلة بين النموذجين ، ولهذا السبب لا يمكن ادخال بيانات في النموذج الفرعي ، إلا على الاقل رقم ID النموذج الرئيسي يتم ادخاله 🙂 جعفر

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

جرب هذا الكود Private Sub CommandButton1_Click() Dim n%, Ro%, i%, x% n = Sheets.Count For i = 1 To n With Sheets(i) .Cells.EntireRow.Hidden = False Ro = .Cells(Rows.Count, "J").End(3).Row For x = 1 To Ro If .Cells(x, "J") = "سدد" Then .Cells(x, "J").EntireRow.Hidden = True End If Next x End With Next i Unload Me End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() Dim n%, i% n = Sheets.Count For i = 1 To n Sheets(i).Cells.EntireRow.Hidden = False Next i Unload Me End Sub الملف مرفق Abou_hassan.xlsm

الكود الصحيح Private Sub TextBox1_Change() Application.EnableEvents = False If ActiveSheet.FilterMode Then _ ActiveSheet.Range("A3").AutoFilter If ActiveSheet.TextBox1.Text <> "" Then Range("$A$3").AutoFilter field:=2, _ Criteria1:="=" & ActiveSheet.TextBox1.Text End If Application.EnableEvents = True End Sub

عند اكمال كتابة النطاق احرص ان يكون المؤشر في نهاية النطاق ثم اضغط f4

السلام عليكم يجب تحديد النطاق k1:k5 قبل الضغط على F4 (أو على الأقل تحديد النقطتين : )

جرب هذا الكود (بعد تسمبة الشيت باسم Data) Option Explicit Sub Compaire_two_Col() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim D As Worksheet Dim Res_range As Range Dim LrA%, i%, x% Dim DIC As Object Set D = Sheets("Data") Set Res_range = D.Range("D1").CurrentRegion Set DIC = CreateObject("Scripting.Dictionary") LrA = D.Cells(Rows.Count, 1).End(3).Row If Res_range.Rows.Count > 1 Then _ Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear With D For i = 2 To LrA Set Res_range = D.Range("J2:J" & LrA).Find(D.Cells(i, 2), lookat:=1) If Not Res_range Is Nothing Then x = Res_range.Row DIC(D.Cells(i, 2).Value) = D.Range("k" & x).Value End If Next If DIC.Count = 0 Then GoTo MY_End D.Range("E2").Resize(DIC.Count) = Application.Transpose(DIC.Items) .Range("F2").Resize(DIC.Count) = Application.Transpose(DIC.Keys) Set Res_range = D.Range("E1").CurrentRegion With Res_range .Sort Key1:=.Cells(1, 1), Header:=1 With .Offset(1).Resize(.Rows.Count - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True: .Font.Size = 14 .Interior.ColorIndex = 19 End With End With End With MY_End: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub File Include Abd_rahman.xlsm

وعليكم السلام 🙂 انا من مؤيدي استخدام اعدادات الاسكانر في عمله ، وهذه الاعدادات تقوم بالعمل بشكل رائع ، بدون تدخّل اي من برمجتنا 🙂 لهذا السبب ، لا تعليق عندي على كود الماسح الضوئي واليك ملاحظاتي على الكود : 1. الكود يأخذ الصور بدقة: DPI = 200 ، والمفروض للأرشفة ان تكون DPI = 300 ، 2. الكود يأخذ صورة للشاشة بحجم A4 ، فيكون هناك مكان فارغ في الكثير من الصور الصغيرة ، وفيه هدر للمساحة التخزينية : Scanner.Items(1).Properties("6151").Value = 8.3 * DPI 'Horizontal extent Scanner.Items(1).Properties("6152").Value = 11.7 * DPI 'Vertical extent for A4 3. لا ادري مقدار الضغط Compression ، لأنه للأرشفة يجب ان لا يكون هناك ضغط ، 4. وفي الواقع انك لما تأخذ صور jpg وتستعمل تقرير الاكسس لجمع هذه الصور ، ومن ثم تحولها الى pdf ، فأنت تعمل تغيير في حجم صور jpg ، وهذا يتنافى مع اصل الارشفة !! ارفقت لك برنامج يعمل كالتالي: تضع البرنامج في مجلد ، وتضع جميع صور jpg في نفس المجلد ، ثم انقر نقرتين على البرنامج ، وفي الشاشة السوداء اضغط على الرقم 1 من الكيبورد ، فتلقائيا يحول لك الصور الى ملف pdf ، وبنفس نقاوة كل صورة (جرب الصور اللي في المرفق) . طبعا لاحقا تقدر برمجيا ان تعطي البرنامج الامر عن طريق Shell مثلا 🙂 جعفر jpg to pdf.zip

و عليكم السلام تحدث عادة على الحواسيب المحمولة اذا كان عندك جهاز محمول مثل dell حاول الضغط على fn+f4 في نفس الوقت - تثبيت النطاق يكون دائما في وضع التحرير للمعادلات و ادا كان لديك hp ادخل الى البيوس bios و غير اعدادات الزر fn رربما تكون غير مفعلة

بعد اذن اخي الرائد لا لزوم للحلفات التكرارية لأكثر من 150 صف من البيانات (يمكن تجربة الكود على قليل من الصفوف 20 صف تقريباً لان الماكرو الذي يعمل على صف واحد يمكنه العمل على الوف الصفوف) 1-استبدال اسم الشيت الى Salim (لأني لا أفضّل التسمية باللغة العربية لحسن نسخ الكود ولصقه بدون مشاكل اللغة) 2- تنفيذ هذا الكود Option Explicit Sub Compaire_two_Col() Dim S As Worksheet Dim Res_range As Range Dim LrA% Set S = Sheets("Salim") LrA = S.Cells(Rows.Count, 1).End(3).Row Set Res_range = S.Range("D1").CurrentRegion If Res_range.Rows.Count > 1 Then _ Res_range.Offset(1).Resize(Res_range.Rows.Count).Clear S.Range("D2").Resize(LrA - 1, 2).Value = _ S.Range("A2").Resize(LrA - 1, 2).Value Set Res_range = S.Range("D1").CurrentRegion With Res_range .Sort Key1:=Res_range.Cells(1, 1), Header:=1 .RemoveDuplicates Columns:=1, Header:=xlYes End With Set Res_range = S.Range("D1").CurrentRegion With Res_range.Offset(1).Resize(Res_range.Rows.Count - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Interior.ColorIndex = 35 End With End Sub الملف مرفق Compair_data.xlsm

(يرفع الله الذين آمنوا منكم والذين أوتوا العلم درجات) ـ هذا هو المطلوب بارك الله فيك ومتعك بصحتك وعافيتك وجعلك من المقبولين والمغفور لهم هنيئا لك يا أستاذنا علي زكاة العلم ـ جزاك الله خيرا ـ لك مني الشكر والدعاء تحياتي

تفضل يمكنك استخدام هذه المعادلة وبكده يكون انتهى الموضوع =IF(C10<=$D$8,((C10*10%))*15%,IF(C10>=$D$8,((C10-$D$8)*15%+($D$8*10%))*55%,"")) ومبارك الترقية الى عضــو ممــيز وسننتظر مشاركاتك الإيجابية ان شاء الله فى مساعدة جميع الأعضاء احتساب المعادلة.xlsx

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

يمكنك استخدام هذا الكود لذلك Sub SelectPrintArea() Dim PrintThis As Range ActiveSheet.PageSetup.PrintArea = "" Set PrintThis = Application.InputBox _ (Prompt:="Select the Print Range", Title:="Select", Type:=8) PrintThis.Select Selection.Name = "NewPrint" ActiveSheet.PageSetup.PrintArea = "NewPrint" ActiveSheet.PrintOut End Sub Print.xls

جرب هذا الملف (الصفحة Target_sh ) الكود Option Explicit Sub Get_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim D As Worksheet, T As Worksheet Dim D_Rg As Range, T_rg As Range, Single_rg As Range Dim RoD%, RoT%, All_ro%, X%, y% Dim Nme$ Set D = Sheets("Data"): Set T = Sheets("Target_sh") Set D_Rg = D.Range("A4").CurrentRegion Set T_rg = T.Range("A3").CurrentRegion RoT = T_rg.Rows.Count If RoT > 1 Then _ T_rg.Offset(1).Resize(RoT - 1).Clear If D.FilterMode Then D_Rg.AutoFilter RoD = D_Rg.Rows.Count Set Single_rg = D_Rg.Offset(1).Resize(RoD - 1) Nme = T.Cells(3, "K") D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "اجل" y = D_Rg.SpecialCells(12).Rows.Count If y > 0 Then Single_rg.Columns(2).SpecialCells(12).Copy T.Range("A4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("B4").PasteSpecial (12) End If D_Rg.AutoFilter D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "نقدا" X = D_Rg.SpecialCells(12).Rows.Count If X = 0 Then Exit Sub Single_rg.Columns(2).SpecialCells(12).Copy T.Range("C4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("D4").PasteSpecial (12) All_ro = T.Range("A3").CurrentRegion.Rows.Count With T.Cells(All_ro + 3, 1) .Value = "المجموع:" .Offset(, 1) = Evaluate("=SUM(B4:B" & All_ro + 2 & ")") .Offset(, 2) = "المجموع:" .Offset(, 3) = Evaluate("=SUM(D4:D" & All_ro + 2 & ")") End With With T.Cells(4, 1).Resize(All_ro, 4) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 13: .Font.Bold = True .Interior.ColorIndex = 38 End With If D.FilterMode Then D_Rg.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Mabieat_Filter.xlsm

هلا اخي جرب هذا الكود DoCmd.TransferDatabase acExport, "Microsoft Access", CurrentProject.Path & "\TESTDB_BACKUP.accdb", acTable, "TABLE1", "TABLE1" مرفق مثال بالتوفيق TEST.zip

من المعروف ان الترجمة الطبيعية لمصطلح Organization هو منظمة و استخدامه دارج فى اللغة الانجليزية لوصف مستويات مختلفة من الجهات الخاصة و الحكومية و المؤسسات و الهيئات و الجهات و المنشئات و لكن من وجهة نظرك أي هذه الترجمات يعد الترجمة المقبولة فى ممارستك العملية لمصطلح Organization من واقع الممارسة العملية يمكنك اختيار اكثر من خيار تعديل: تم اضافة بعض أمثلة الاستخدام بناء على بناء على الملاحظات التي وردت من الأخوة بضرورة وجود سياق يتم فيه الاختيار أضفت بعض الجمل التي يمكن أن تساعد على التفكير فى سياق جملة محددة: اختر مما يلي: منظمة - مؤسسة- شركة - كيان-منشأة - جهة - العمليات المستخدمة من قبل موظفي ---- التي تعمل بها - يجب على كافة الموظفين العمل على تحسين و تطوير الأداء لل ----- التي بعملون بها بشكل مستمر - ماهي المنتجات أو الخدمات التي تقدمها ال------ التي تعمل بها - قرار إداري يوضح الوحدات التنظيمية المختلفة لل ------- التي تعمل بها -ال ----- المنفذة للمشروع - مدير المشروع هو المكلف من قبل ال --- التى يعمل بها لتحقيق اهداف المشروع

يقصد الاستاذ جعفر بالمثال هو ان تضع مرفقا مصغرا تظهر المشكلة فيه ويمكن التعديل عليه

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

وعليكم السلام بالطبع لا يمكن عمل هذا الا بدالة معرفة Option Explicit Function Lookup_concat(Search_string As String, _ Search_in_col As Range, Return_val_col As Range) Dim i As Long Dim result As String For i = 1 To Search_in_col.Count If Search_in_col.Cells(i, 1) = Search_string Then result = result & "," & Return_val_col.Cells(i, 1).Value End If Next Lookup_concat = Trim(result) End Function ووضع هذه المعادلة بداية من الخلية H3 سحباً للأسفل =Lookup_concat($G3,$A$2:$A$700,$B$2:$B$700) Test1.xlsm

وعليكم السلام 🙂 اعمل نسخة احتياطية قبل العمل !! انزل هذا البرنامج المجاني : http://www.skrol29.com/us/vtools.php وبعد التنصيب ، استعمل خاصية . . جعفر

هذا الكود البسيط Sub Show_all() Sheets("Sheet1").Rows.Hidden = False End Sub

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

مع اني لا أحب التغامل مع اليوزرفورم اليك هذا الملف Private Sub CommandButton1_Click() Sheets("Sheet1").Rows.Hidden = False Sheets("Sheet1").Cells(2, "H").Resize(, 2) = "" If Me.TextBox1 = "" Or Me.TextBox2 = "" Then Exit Sub Dim Mx As Date, Mn As Date Mx = Application.Max(Me.TextBox1, Me.TextBox2) Mn = Application.Min(Me.TextBox1, Me.TextBox2) Dim I%, Ro% Ro = Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row Sheets("Sheet1").Cells(3, 1).Resize(Ro).Rows.Hidden = True For I = 3 To Ro If CDate(Sheets("Sheet1").Cells(I, 2)) >= Mn And _ CDate(Sheets("Sheet1").Cells(I, 2)) <= Mx Then _ Sheets("Sheet1").Cells(I, 1).EntireRow.Hidden = False Next Sheets("Sheet1").Cells(2, "H") = Mn Sheets("Sheet1").Cells(2, "I") = Mx: Unload Me End Sub الملف مرفق filter-date_Sal.xlsm

تفضل EXEMPLE.xlsm

@essam rabea شكرا جزيلا اشتغل العربي

راجع هذا الرابط عسي ان يفيد بالتوفيق

بالفعل شرحك اجمل واروع من اي شئ ارفع لك القبعة علي اختيار مواضيعك الاكثر من رااائعة جزاك الله خيرا وفي انتظار باقي دروس الموضوع