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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي حاولت تنفيدها بطريقة اخرى لتكون النتائج ادق وعدم تسبب المعادلات بثقل للملف زيادة على غياب تطابق عناوين الاعمدة على الجداول ودالك بتحويل المعادلات الى اكواد ووضع لكل يوم كود معين يتم تنفيده بشرط قيمة الخلية S3 ملاحظة 1) لقد قمت بحدف المغادلة الخاصة بجلب اسم اليوم من التاريخ في الخلية S3 ووضعت قائمة منسدلة تتضمن الايام من الاحد الى الخميس عند اختيارك اليوم المناسب يتم جلب بياناته تلقائيا 2) تم الاستغناء على معادلة الترقيم التلقائي للبيانات في عمود A واستبدالها بالاكواد 3) يتم تنفيد الكود المناسب عند التغيير في عمود الاسماء تلقائيا الكود الخاص بيوم الاحد للتوضيح Sub Sunday() Dim F1$, F2$, F3$, F4$, F5$, F6$, F7$, F8$, A$, B$, J% Dim MyRng As Range, MyDst As Range, Title As Range, R As Range, D As Range Dim MyDest As Worksheet: Set MyDest = Feuil1 Dim MyData As Worksheet: Set MyData = Feuil2 A = MyDest.Name B = MyData.Name Set C = MyData.Range("$D$4:$M$24") Set D = MyDest.Range("A22:A31") Set Title = MyDest.Range("B22:B31") Set MyRng = MyDest.Range("F22:U31") Application.ScreenUpdating = False MyDest.Unprotect "0000" D.ClearContents With MyDest F1 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",2,0),"""")" F2 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",4,0),"""")" F3 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",5,0),"""")" F4 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",6,0),"""")" F5 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",7,0),"""")" F6 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",8,0),"""")" F7 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",9,0),"""")" F8 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",10,0),"""")" [F22] = F1: [H22] = F2: [J22] = F3: [L22] = F4: [N22] = F5: [P22] = F6: [R22] = F7: [T22] = F8 .Range("F22:U22").AutoFill Destination:=.Range("F22:U31"), Type:=xlFillDefault MyRng.Value = MyRng.Value For Each R In Title If R.Value <> Empty Then J = J + 1 R.Offset(0, -1).Value = Format(J, "0") End If Next MyRng.Replace 0, "", xlWhole End With MyDest.Protect "0000" End Sub الكود الخاص بتنفيد الكود المناسب عند التغيير في خلية اليوم Sub Results() Select Case Range("S3") Case "الأحد": Sunday Case "الاثنين": Monday Case "الثلاثاء": Tuesday Case "الأربعاء": Wednesday Case "الخميس": Thursday End Select End Sub مع وضع الكود التالي في Worksheet.Change الورقة 1 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("B22:B31")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True Exit Sub End If If Not Intersect(Target, Range("S3")) Is Nothing Then Application.EnableEvents = False Call Results Application.EnableEvents = True End If On Error GoTo 0 End Sub التقرير اليومي مبرمج 2023.xlsm

اختيار من متعدد بطريقة جديده multiselectform.accdb

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

السلام عليكم جرب هذه الطريقة من هذه النافذة اختر زر الخيارات ستظهر النافذة التالية العمود الاول هو ترتيب الاعمدة ، الثاني لاظهار الاعمدة ، الثالث اسم العمود ، الرابع حجم العمود بامكانك بازرار الاعلى والاسفل تحريك العمود للاعلى والاسفل Database6.accdb

حضرتك اكتب الكود كحقل فى الاستعلام بجانب حقل (الحالة و تاريخ الدخول و تاريخ الخروج ) وليس معيار او ارفق مثال صغير للتعديل عليه الكود الصحيح iif(isnull ([dateout]);"To this day" ; [dateout] ) Test.accdb

السلام عليكم اعضاء الكنترول الكرام اضع بين ايديكم شيت كنترول جدارات _ قسم حاسبات " الصف الاول "_ مفتوح المصدر يشتمل على ♦ شيت الرصد ♦ شهادات التيرم الاول ♦ شهادات نهاية العام ♦ تحديد الاوائل في الشهادة " هذا العمل خالصا لوجه الله تعالى " hasbat_1_gdarat.xlsm

السلام عليكم لدي المرفق التالي للاخ @الحلبي ولكن المطلوب التعديل عليه اولا :- يتم اخذ الملفات من السكنر وتصديرها بصيغة ال PDF وليس صورة ثانيا :- تقليل درجة الجودة المأخوذه حيث بالملف الاعدادات الحالية اعلى دقة HALABI _ up1 .rar

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

يتم دالك بسبب نسخ قيمة Textbox مكان المعادلة هناك 2 حلول اما استبدال الكود بكود يتوافق مع شكل وتصميم الملف او تعديله بالطريقة التالية وهي الاستغناء عن وضع المعادلة يدويا وتعويضها بواسطة الاكواد على النحو التالي Private Sub CommandButton3_Click() Dim DerLig As Long, X As Long Dim WSData As Worksheet: Set WSData = ActiveSheet DerLig = WSData.Range("C" & WSData.Rows.Count).End(xlUp).row Application.ScreenUpdating = False If Me.TextBox1.Value = Empty Then: Exit Sub X = Application.Match(Val(TextBox1.Value), WSData.Columns("C"), 0) If Not IsError(X) Then For i = 2 To 18 WSData.Cells(X, i + 2).Value = Controls("TextBox" & i).Value WSData.Cells(X, i + 2).Value = WSData.Cells(X, i + 2).Value Next i End If For r = 1 To 18 Me("Textbox" & r) = "" Next r WSData.Range("C10").Value = 1 WSData.Range("C10:C" & DerLig).DataSeries , xlDataSeriesLinear ' وضع المعادلة WSData.Range("P10:P" & DerLig).Formula = "=IF(N10="""","""",""(""& O10&"" / ""&N10&"")"")" With WSData.Range("P10:P" & DerLig) .Value = .Value End With End Sub مني 4.xlsm

اخيرا تمكنت من سحب ملفات pdf من دون برنامج اكروبات الآن ومن اجل اظهار الملفات : كيف تريد صفة العرض ؟ 1- هل لكل ملف سجل خاص ؟ 2- ماهو معرف الصورة في السجل ؟ هل هو رقم الكتاب ؟ 3- اذا جميع الملفات التي يتم سحبها دفعة واحدة تخص سجل واحد (رقم الكتاب ) فهذا يستلزم وجود جدول فرعي يرتبط بمعرف الصورة في الرئيسي راجع استفساراتي وبناء عليها ارفع مرفقا معدلا

متشكره جدا لاهتمام حضراتكم لما نقلت الكود عندى بيدينى ايرور ممكن حد يشوف الملف ويعدله مشكورا lab4 (1).rar

لو جعلت خصيصة الحقل في الجدول مطلوب = نعم لتحقق طلبك

شكرا جزيلا وجاري تطبيقها ع البرنامج

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

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

اتفضلى يا استاذة ان شاء الله يكون فى المرفق التالى كل طلباتك lab4.accdb

لسلام عليكم و رحمة الله جزاك الله خيرا اخي

بالنسبة للملاحظة الثانية استبدل السطر بهذا وسوف يتم ترقيم الصور Shell ("c:\Program Files (x86)\irfanview\i_view32.exe /batchscan=(Ahmed,1,1,2,1," & mypath & " ,jpg,1) /scanhidden") اما الملاحظة الاولى او الخطوة الاخيرة فكما ذكرت لك لا املك اكروبات في جهازي

ألف ألف شكر نجحت الطريقة ربي يجازيك أخي خير الجزاء ألف ألف شكر نجحت الطريقة ربي يجازيك أخي خير الجزاء

بعد التعديل . CalculatAge-1.accdb

اخي احمد صحيح النظام له يد قمت بازالة البرنامج الوسيط 64 ونصبت نظام 32 .. وعمل القبيح على اكمل وجه وبما اني لا ملك في جهازي اكروبات جعلت عملي على الصور .. واكيد ما ينطبق على الصور سينطبق على pdf وابشرك نجحت في اختيار مكان الحفظ Dim mypath As String mypath = Application.CurrentProject.Path & "\My_Archive\Import\My_Pictures\" Shell ("c:\Program Files (x86)\irfanview\i_view32.exe /batchscan=(Ahmed,,,,," & mypath & " ,jpg,0) /scanhidden") جرب الصور .. ثم افحص الـــــ pdf هذه هي الخطوة الأولى الخطوة الثانية وهي اظهار الملف على النموذج اذا لم تتمكن من اظهار pdf .. فلكي اعينك يتوجب علي تركيب اكروبات

تفضل أخي . السجل الاشرافي.accdb

الموضوع قديم جدا .. له عقدين من السنين ومع ذلك تفضل الحل يكون في خصائص الجدول db3.rar

لكن أخي الملف غير مطابق للصورة المرفقة اين مكان وجود الجدول الذي يتضمن أسماء الأيام

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب =IF(B22="","", INDEX(Feuil2!$G$4:G24, MATCH(B22, Feuil2!$D$4:D24, 0),1)) مع تغير Feuil2!$G$4:G24 باسم العمود المراد جلب بياناته في باقي الاعمدة او =IF(B22<>"",INDEX(Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24)/(Feuil2!$D$4:$D$24=B22),ROWS(C22:C22))),"") مع التغيير هنا بما يناسبك (Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24) =IFERROR(VLOOKUP(Feuil1!$B22,Feuil2!$D$4:$M$24,2,0),"") مع استبدال رقم 2 برقم العمود المراد جلب بياناته او =IF(B22="","",XLOOKUP(B22,Feuil2!$D$4:$D$24,Feuil2!$E$4:$E$24)) التقرير-اليومي 2022 مبرمج.xlsm

هكذا؟ Sub Triage() With ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2") .Sort.SortFields.Clear .Sort.SortFields.Add Key:=Range("Tableau2[Date Echeance]") .Sort.SortFields.Add2 Key:=Range("Tableau2[Client]") With .Sort .Header = xlYes .Apply End With End With End Sub

السلام عليكم ممكن تعديل في الكود ليصبح فرز مخصص أي بعد الفرز في العمود F يقوم بفرز العمود B هذا الكود كنت أستعمله يدويا Sub Triage() ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2").Sort.SortFields.Clear ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2").Sort.SortFields.Add _ Key:=Range("Tableau2[Date Echeance]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2").Sort.SortFields.Add _ Key:=Range("Tableau2[Client]"), SortOn:=xlSortOnValues, Order:= _ xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("BLF").ListObjects("Tableau2").Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub

عليكم السلام جرب Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("f:f")) Is Nothing Then Range("Tableau2[[#Headers],[#Data]]").Sort Key1:=Range("f1"), Order1:=xlAscending, Header:=xlYes End If End Sub

بيانات الموظفين.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Recherche() Dim lastrow As Long, Col As Long Set wsdest = ThisWorkbook.Sheets("Feuil1") Set wsdata = ThisWorkbook.Sheets("Feuil2") lastrow = wsdata.Cells(Rows.Count, "C").End(xlUp).Row If Application.WorksheetFunction.CountA(wsdest.Range("AE7:AM7")) = 0 Then MsgBox "!!!المرجوا إدخال معايير الفلترة " & vbCrLf, vbInformation + vbOKOnly, " ! تنبيه" Exit Sub End If Application.ScreenUpdating = False ' إلغاء حماية الورقة wsdest.Unprotect "0000" If wsdest.AutoFilterMode Then wsdest.AutoFilterMode = False Col = wsdest.Cells(Rows.Count, "AE").End(xlUp).Row ' افراغ البيانات السابقة wsdest.Range("AE15:AM" & Col).Clear 'Contents 'نطاق الفلترة wsdata.Range("C27:K" & lastrow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsdest.Range("AE6:AM7"), _ CopyToRange:=wsdest.Range("AE14:AM14"), _ Unique:=True If Application.WorksheetFunction.CountA(wsdest.Range("AE15:AM15")) = 0 Then résultat = MsgBox("ليس هناك بيانات مطابقة لمعايير الفلترة الحالية", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه") End If On Error Resume Next ' اخفاء الصيغ wsdest.UsedRange.SpecialCells(xlCellTypeFormulas).FormulaHidden = True On Error GoTo 0 ' ارجاع الحماية لورقة العمل wsdest.Protect "0000" Application.ScreenUpdating = True End Sub التقرير-اليومي 2022 مبرمج.xlsm

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

المشكلة كانت في عدم ترتيب الصفوف حسب الــ Grade تم معالجة الأمر بتعديل الكود بحيث يعمل في كل الاحتمالات (ترتيب او عدم الترتيب) Sub First_Third_New() Dim sh As Worksheet Dim sh1 As Worksheet Dim My_rg As Range Dim F_rg As Range, xx As Long Dim ro As Long, i As Long, a% Dim k As Byte, m As Byte Dim Cret1, Cret2 Dim Col As Object, Dic As Object Dim Lt, t%, Ar_count, y, kk% Dim Mn, A_arr() Application.ScreenUpdating = False Set sh = Sheets("Salim") Set sh1 = Sheets("Sheet1") Set My_rg = sh.Range("A1").CurrentRegion Set Col = CreateObject("System.Collections.ArrayList") Set Dic = CreateObject("Scripting.Dictionary") sh1.Range("C8:M13").ClearContents ro = My_rg.Rows.Count sh.Cells(2, 1).Resize(ro - 1, 12).Interior.ColorIndex = xlNone If sh1.Range("V8") = "" Then sh1.Range("V8") = "Grade 1" If sh1.Range("V7") = "" Then sh1.Range("V7") = "Arabic Language" Cret1 = sh1.Range("V8"): Cret2 = sh1.Range("V7") If sh.FilterMode Then My_rg.AutoFilter End If My_rg.AutoFilter Field:=1, _ Criteria1:=Cret1 My_rg.AutoFilter Field:=3, _ Criteria1:=Cret2 Set My_rg = My_rg.Columns(13) _ .Resize(ro - 1).SpecialCells(12) Mn = Application.Large(My_rg, 5) Ar_count = My_rg.Areas.Count For y = 2 To Ar_count For kk = 1 To My_rg.Areas(y).Rows.Count ReDim Preserve A_arr(a) A_arr(a) = _ My_rg.Areas(y).Cells(kk) a = a + 1 Next kk Next y If a = 0 Then Exit Sub For i = LBound(A_arr) To UBound(A_arr) If IsNumeric(A_arr(i)) Then Col.Add Val(A_arr(i)) End If Next i Col.Sort Col.Reverse For t = 0 To Col.Count - 1 If Col(t) >= Mn Then Dic(Col(t)) = vbNullString End If Next m = 8: t = 0 Do Until t = Dic.Count + 1 Set F_rg = My_rg.Find(Dic.keys()(t) _ , lookat:=1) If Not F_rg Is Nothing Then xx = F_rg.Row: Lt = xx Do sh.Cells(Lt, 1).Resize(, 12).Interior.ColorIndex = 6 With sh1.Cells(m, "C") .Value = sh.Cells(Lt, "B") .Offset(, 1).Resize(, 9).Value = _ sh.Cells(Lt, "D").Resize(, 9).Value .Offset(, 10) = F_rg m = m + 1 End With Set F_rg = My_rg.FindNext(F_rg) Lt = F_rg.Row If Lt = xx Then Exit Do Loop End If t = t + 1 If t = Dic.Count Then Exit Do Loop If sh.FilterMode Then My_rg.AutoFilter End If Application.ScreenUpdating = True Set sh = Nothing Set My_rg = Nothing: Set F_rg = Nothing Set Col = Nothing: Set Dic = Nothing Erase A_arr End Sub Masry_Super.xlsm

تعديل بالنسبة للغة الأجنبيىة كل شيء تمام (لا مشاكل في الاسطر الفارغة) بالنسبة للغة العربيى هناك مشكلة بالصفوف الفارعة (ولا أعرف طريقة حلها) List_box52.xlsm

الأفضل رقع ملفات بدون زركشة الوان (اسهل على المتابعة) مبدئياً هذا الكود (يتحاهل النصوص والفراغات) Sub sum() Dim mr As Worksheet Dim lr%, i%, x% Set mr = Sheets("mark-s") With mr lr = .Range("c" & Rows.Count).End(xlUp).Row For i = 9 To lr For x = 12 To 103 Step 13 With .Cells(i, x) .Value = _ Val(.Offset(, -3)) + _ Val(.Offset(, -2)) + _ Val(.Offset(, -1)) End With Next x Next i End With End Sub

جرب هذا الكود Option Explicit Dim x%, y% Dim Dic As Object Dim Sh As Worksheet Dim My_rg As Range Sub All_in_One() Application.ScreenUpdating = False Set Sh = Sheets("Sheet1") Set Dic = CreateObject("Scripting.Dictionary") With Sh .Range("H1").CurrentRegion.Clear For y = 1 To .Range("A1").CurrentRegion.Columns.Count For x = 2 To _ .Range("A1").CurrentRegion.Rows.Count If .Cells(x, y) <> "" Then Dic(.Cells(x, y).Value) = "" End If Next x Next y If Dic.Count = 0 Then GoTo Bay_Bay .Range("H1") = "ALL" .Range("H2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) If .Range("H1").CurrentRegion.Rows.Count > 1 Then With .Range("H1").CurrentRegion .Borders.LineStyle = 1 .Font.Bold = True: .Font.Size = 14 .InsertIndent 1 .Interior.ColorIndex = 35 .Cells(1, 1).Interior.ColorIndex = 6 End With End If End With Bay_Bay: Set Sh = Nothing Set Dic = Nothing Application.ScreenUpdating = True End Sub الكلف مرفق abou_has_All_in_one.xlsm

لعمل ذلك هذا الماكرو Option Explicit Sub ALL_data() Dim B As Worksheet: Set B = Sheets("SALIM") Dim sh_name$: sh_name = B.Range("j1") On Error Resume Next If Len(Sheets(sh_name).Name) = 0 Or sh_name = vbNullString Then Exit Sub On Error GoTo 0 Dim N As Worksheet: Set N = Sheets(sh_name) Dim Dic As New Dictionary Dim i%: i = 2 B.Range("a4").CurrentRegion.Clear With N Do Until .Range("a" & i) = vbNullString Dic(i - 2) = .Range("a" & i).Resize(, 64) i = i + 1 Loop For i = 0 To Dic.Count B.Range("a" & i + 5).Resize(, 64) = Dic.Item(i) Next End With With B.Range("a5").CurrentRegion .Interior.ColorIndex = 35 .Borders.LineStyle = 1 .InsertIndent 1 End With N.Range("a1").Resize(, 64).Copy _ B.Range("a4") Dic.RemoveAll End Sub الملف مرفق صفحة SALIM _Salim_File_NEW.xlsm

‍جرب هذا الماكرو Option Explicit Sub get_data() Dim B As Worksheet: Set B = Sheets("BASMMA") Dim sh_name$: sh_name = B.Range("j1") On Error Resume Next If Len(Sheets(sh_name).Name) = 0 Or sh_name = vbNullString Then Exit Sub On Error GoTo 0 Dim N As Worksheet: Set N = Sheets(sh_name) Dim Dic As New Dictionary Dim i%: i = 2 Dim x With N Do Until .Range("B" & i) = vbNullString If Not Dic.Exists(.Range("B" & i).Value) Then Dic.Add .Range("B" & i).Value, .Range("F" & i).Resize(, 59).Value End If i = i + 1 Loop B.OLEObjects("Combobox1").Object.List = Dic.Keys End With x = N.Range("B:b").Find(B.Range("h2")).Row With B .Range("a2") = N.Cells(x, 1) .Range("b2") = N.Cells(x, 2) .Range("c2") = N.Cells(x, 4) .Range("e2").Resize(59, 1).Value = _ Application.Transpose(Dic.Items(x - 2)) End With Dic.RemoveAll End Sub الملف مرفق ‌Salim_File.xlsm