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

احببت ان افرد موضوعي هذا بعنوان مستقل 1-لان غالب او جميع الدروس هنا تتعامل مع واتساب ويندوز 2-وحتى يكون تطوير هذا العمل مستقلا ولا يحدث خلط بين الامثلة المثال المرفق تم تطبيقه على واتساب ويب واليكم بعض التوجيهات والملاحظات : كانت مشكلتي في محاولات سابقة انه في كل مرة يتم الارسال وفتح الواتساب ويب .. فانه يطلب ربطا جديدا بالجوال وبحمد الله توصلت الى حل هذه المشكلة التي كانت عائقا حقيقيا .. يكتفى بالارتباط مرة واحدة فقط الآن : عند كل ارسال يفتح الواتس ويب بشاشة جديدة .. فان كانت هناك نسخة مفتوحة من قبل فانه يتجاهلها وتصبح غير فعالة وهذه لا مشكلة فيها لأنه يفتح على الحساب نفسه . ارجوا من اخوتي واحبتي الذين يمرون من هنا تجربة المثال وافادتي بنتيجة التجربة ، من اجل الانتقال الى الخطوة التالية وهي ارسال المرفقات sendwatsWeb.mdb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ربما هدا طلبك . تقسيم البيانات كل اسبوع في ورقة مستقلة مع انشاء مجلد في القرص (E) وحفظ الملفات بداخله بصيغة (PDF) مع تنسيق الجداول بنفس التنسيق المرفق في طلبك . Public Sub Split_Sheet_condition_of_the_week() Dim dataSheet As Worksheet, weekSheet As Worksheet Dim minDate As Date, maxDate, weekStartDate As Date Dim lr As Long, c As Long, LastRow As Long, MH As Variant Dim weekSheetName As String, WS_Address As String Dim ST_DATA, ST_Name, ST_Path, ST_WS_Data As String Dim WS_Data As Range, Total_Rng As Range Dim wsData As Worksheet: Set wsData = Worksheets("تجميع") 'حدف جميع اوراق العمل باستثناء ورقة التجميع Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "تجميع" Then Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True End If Next Set dataSheet = wsData With dataSheet lr = .Cells(.Rows.Count, "F").End(xlUp).Row 'اصغر تاريخ minDate = Application.WorksheetFunction.Min(.Range("F2:F" & lr)) ' اكبر تاريخ maxDate = Application.WorksheetFunction.Max(.Range("F2:F" & lr)) End With weekStartDate = Date_Prev_Saturday(minDate) While weekStartDate <= maxDate 'تسمية الشيتات weekSheetName = Format(weekStartDate, "d") & " To " & Format(weekStartDate + 6, "d") With ActiveWorkbook Set weekSheet = Nothing On Error Resume Next Set weekSheet = .Worksheets(weekSheetName) On Error GoTo 0 If weekSheet Is Nothing Then 'اظافة وتسمية اوراق العمل Set weekSheet = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)) weekSheet.Name = weekSheetName weekSheet.DisplayRightToLeft = True Else weekSheet.Cells.Clear End If End With 'فلترة البيانات weekSheet.Range("l1:m1").Value = Array(dataSheet.Range("F1").Value, dataSheet.Range("F1").Value) weekSheet.Range("l2:m2").Value = Array(">=" & CLng(weekStartDate), "<=" & CLng(weekStartDate) + 6) dataSheet.Range("F1:k" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=weekSheet.Range("l1:m2"), CopyToRange:=weekSheet.Range("A4"), Unique:=False weekSheet.Range("l1:m2").Clear weekSheet.Columns("A:F").EntireColumn.ColumnWidth = 16 LastRow = weekSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Set Total_Rng = Range(weekSheet.Cells(LastRow + 1, "A"), weekSheet.Cells(LastRow + 1, "F")) MH = (RGB(153, 153, 255)) ' اظافة المعادلات weekSheet.Range("F5").Formula = "=COUNTIF(تجميع!$f$2:$f$500,a5)" weekSheet.Range("F5").AutoFill Destination:=Range("F5:F" & LastRow) weekSheet.Range("E5:E" & LastRow) = "=sum(B5*D5)" Cells(LastRow + 1, 1).Value = "المجموع" For c = 2 To 6 Cells(LastRow + 1, c).Value = Application.Sum(Range(Cells(5, c), Cells(LastRow, c))) Next c 'تنسيق الجدول Total_Rng.Interior.Color = MH Total_Rng.Font.Bold = True Total_Rng.Font.Size = 13 With Range("A5:F" & LastRow + 1) .HorizontalAlignment = xlCenter .Font.Name = "Calibri" .Font.Size = 16 .Value = .Value End With 'تسطير الجدول DL = weekSheet.Range("A65500").End(xlUp).Row DC = weekSheet.Cells(5, Columns.Count).End(xlToLeft).Column Range(weekSheet.Cells(5, 1), weekSheet.Cells(DL, DC)).Borders.Weight = xlThin 'فواصل الصفحات With weekSheet.Range("A5:A" & _ weekSheet.Range("A" & Rows.Count).End(xlUp).Row) Set WS_Data = weekSheet.Cells.Find(What:="المجموع", LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, _ SearchDirection:=xlNext) If Not WS_Data Is Nothing Then WS_Address = WS_Data.Address Do If Not WS_Data Is Nothing Then WS_Data.Offset(1).PageBreak = xlPageBreakManual End If Set WS_Data = .FindNext(WS_Data) If WS_Data Is Nothing Then Exit Do End If If WS_Data.Address = WS_Address Then Exit Do End If Loop End If End With On Error Resume Next ActiveWindow.View = xlPageBreakPreview weekSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1 ActiveWindow.View = xlNormalView ' إنشاء مجلد الحفظ ST_Name = "فرز البيانات الأسبوعية" ST_DATA = "" ST_WS_Data = "E:\" ' قم بتغييره بما يناسبك 'ST_WS_Data = "D:\" If IsEmpty(ST_Name) Then Exit Sub If IsEmpty(ST_DATA) Then Exit Sub MkDir ST_WS_Data & "\" & ST_Name ST_Path = ST_WS_Data & "\" & ST_Name & "\" & ST_DATA ' مسار وضع الشيتات بصيغة (PDF)""""""""""""""""""""""""""""" مسار مجلد الحفظ weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="E:\فرز البيانات الأسبوعية\" & weekSheet.Name & "_" & Format(Now, "MMMM") & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=False weekStartDate = weekStartDate + 7 Wend dataSheet.Select MsgBox "" & ST_WS_Data & ST_Name & vbLf & vbLf & vbLf & "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy") & " " & _ FolderName, _ vbInformation, " : تم حفظ الملفات بنجاح في " On Error GoTo 0 Application.ScreenUpdating = True End Sub Private Function Date_Prev_Saturday(fromDate As Date) As Date Date_Prev_Saturday = fromDate - Weekday(fromDate) + vbSaturday + 7 * (vbSaturday > Weekday(fromDate)) End Function بالتوفيق.......... تجميع V1.xlsm

تفضل هذا بمعادلة مصفوفة (Ctrl+Shift+Enter) Report Between Two Dates.xlsb

السلام عليكم و رحمة الله استخدم الكود التالى Sub GetData() Dim Sh As Worksheet, ws As Worksheet Dim LR As Long, Countr As Long, p As Long Dim Arr(), Fsl As String, C As Range, j As Long Set Sh = Sheets("saad") Sh.Range("C14:T1000") = "" Fsl = Sh.Range("R12") For Each ws In Worksheets If ws.Name <> Sh.Name Then LR = ws.Range("C" & Rows.Count).End(3).Row Countr = Countr + LR End If Next ReDim Preserve Arr(Countr, 18) For Each ws In Worksheets If ws.Name <> Sh.Name Then For Each C In ws.Range("C10:C" & LR) If C.Offset(0, 15).Value = Fsl Then p = p + 1 For j = 0 To 17 Arr(p - 1, j) = C.Offset(0, j) Arr(p - 1, 0) = p Next End If Next End If Next If p > 0 Then Sh.Range("C14").Resize(p, UBound(Arr, 2)).Value = Arr End Sub

وعليمن السلام بالإذن خيار آخر Sub test() Dim a, b: Dim lr& a = ActiveSheet.Range("D6:D14").Resize(, 4) ReDim b(1 To 5) b = Array(1, 3, 5, 7, 9) Workbooks.Open ("C:\Users\Ehab Elhady\Desktop\1.xlsx") With Sheets("sheet1").Cells(1, 1).Resize(, 5) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Offset(lr).Value = Application.Index(a, b, 1) .Offset(lr, 5).Value = Application.Index(a, b, 4) End With Workbooks("1.xlsx").Close True End Sub

تفضل اخي هدا حل اخر على حسب ما فهمت من اخر ملف قمت برفعه تمت اظافة شيت جديد باسم النتائج لاستخراج تقرير كل اسبوع على حده تحت بعض في ورقة واحدة كما في الصورة ادناه . شيت النتائج مع استخراج بيانات كل اسبوع في شيت مستقل بدون تكرار للتواريخ . وحفظ الكل في مجلد في بارتشن (E) فرز بيانات V2.rar

بالاذن من الاستاذ Lionheart بنفس الطريقة Sub test1() Dim a Dim r As Range Dim frA Dim x& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("ÇáÌÏæá") Set r = Range("B:B").Find("ÇáÑÞã", , , , 1) frA = r.Address If Not r Is Nothing Then Do r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 Set r = .Range("B:B").FindNext(r) Loop Until frA = r.Address End If End With End Sub وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت Sub test2() Dim a Dim r As Range Dim frA Dim x&, i&, ii& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("الجدول") For i = 1 To UBound(a) Step 10 .Cells(4 + ii * 20, 2).Select .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 ii = ii + 1 Next End With End Sub المرفق مع الخيارين sabah.xlsm

مشاركة مع الخبير @kanory مجرد افكار لا اكثر نمارس هواية البرمجة مع بعض التأملات خذ بعض الافكار الي اضفتها لبرنامجك - اضفت لك جدول و في داخله كلمة مرور - عشان تعرض السطور المخفية راح يطلب منك كلمة مرور طبعا هي نفسها الي في الجدول 1234 بسيطة جدا اشكرا على المتابعة - تقدر تحتفظ باختيارك في عرض الصفوف و اخفائها للمرة القادة في زيارتك الميمونة - خطاباتك اذا برنامج ما حصل الخطاب في الفولدر راح يعطيك رسالة تنبيه رايقة جدا بدون تخويف اتمنى تعجبك الفكرة مجرة افكار خلال لحظات تأمل و اشكرك و اشكر كل من قرأ بتأمل و اعطاني وقته الثمين برنامج متابعة.zip

لقد حاولت وبفضل الله نجح الامر معي والشكر لجميع أعضاء المنتدى الشكر موصول للأخ Lionhear Option Explicit Sub Get_Data_From_Closed_Workbooks() Dim a, wb As Workbook, ws As Worksheet, sFile As String, sPath As String, lr As Long, m, x, y, z As Long Application.ScreenUpdating = False sPath = ThisWorkbook.Path & "\" & "تقارير" & "\" sFile = Dir(sPath & [k6] & "*" & ".xlsx") m = 9 With Sheet12.Range("b8").CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With Do While sFile <> "" Set wb = Workbooks.Open(sPath & sFile, ReadOnly:=True) Set ws = wb.Sheets(1) With ws lr = .Cells(Rows.Count, "b").End(xlUp).Row a = .Range("b9:o" & lr).Value x = [c6] y = [e6] z = [h6] .Parent.Close False End With Sheet12.Range("b" & m).Resize(UBound(a, 1), UBound(a, 2)).Value = a m = m + UBound(a, 1) sFile = Dir() Loop With Sheet12.Range("b9:o" & m - 1) .Borders.Value = 1 End With [c6] = x [e6] = y [h6] = z End Sub

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

وعليكم السلام معادله مقدار الدرجات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,10,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,10,0)) معادله الملاحظات =IF(F4="","",VLOOKUP(F4,'بيانات المعلمين'!$A$2:$K$212,9,0)) =IF(F5="","",VLOOKUP(F5,'بيانات المعلمين'!$A$2:$K$212,9,0)) تجربة 1.xls

وعليكم السلام -يمكنك استخدام هذه المعادلة =IFERROR(INDEX(ورقة1!B2:B270,MATCH(0,COUNTIF($A$1:A1,ورقة1!B2:B270),0)),"") تلخيص1.xlsx

اليك حل اخر Sub CopyData() Dim x, y(), i&, lr&, ws_rng2&, ws_rng3& Set ws_rng = Sheet1 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row x = ws_rng.Range("A2:B" & lr) For i = 1 To UBound(x, 1) If x(i, 2) <> 0 Then ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3) For ws_rng2 = 1 To UBound(x, 2) y(ws_rng2, ws_rng3) = x(i, ws_rng2) Next End If Next ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y) End Sub آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض ورقة عمل جديد.xlsm

موعدنا اليوم مع تطبيق ضمن سلسلة ما خف وزنه وغلا ثمنه لأحبابي أعضاء وزوار منتدى أوفيسنا تطبيق يساعدك في إنشاء رسائل msgbox بصورة احترافية فقط اختر الأزرار والعنوان ونص الرسالة والأيقونة وباقي الخيارات ثم اضغط على زر تجربة لمشاهدة كود الرسالة ثم قم بنسخ الكود لبرنامجك ويمكنك استخدام الثوابت والقيم في كتابة الكود وفي الأخير لا ينقصني سوى دعاؤكم msgboxbuilder.rar

حسب الصورة عسى Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub Book1.xlsm

عليكم السلام عسى رصيد لكل مادة حسب المخزن.xlsx

وعليكم السلام-ياريت تقوم بتغيير عنوان المشاركة ليصبح ( معادلة IF متعددة الشروط) وهذه المعادلة تفى بالغرض وشكراً =IF(AND($C4<>"غ",$B4="ذكر"),"ناجح",IF(AND($C4<>"غ",$B4="أنثي"),"ناجحة",IF(AND($C4="غ",$B4="ذكر"),"ناجح بحكم القانون",IF(AND($C4="غ",$B4="أنثي"),"ناجحة بحكم القانون","")))) معادلة IF.xlsx

وعليكم السلام-تفضل هذه المعادلة تخص اللون الأخضر =COUNTIFS($G$5:$G$700,">=9",$G$5:$G$700,"<=10") أما اللون الأحمر فيكفيك هذه المعادلة ...وشكراً =COUNTIF($G$5:$G$700,"<=4") فرق بين تاريخين.xlsx

تفضل هذه الفكرة بناء جدول تلقائي من خلال الكود بناء على بيانات الجدول test.accdb

اصدقائي الاكارم السلام عليكم و رحمة الله و بركاته تحية طيبة يمكن عن طريق المثال التالي انشاء كود QR يدعم اللغة العربية اولا ننسخ المجلد interop(vba) الى المجلد C:\Windows ثم نشغل الملف register.cmd كمسؤول ثم نستخدم المرفق للحصول على كود QR انشاء كود QR.rar

تفضل اخي الكريم New Microsoft Excel Worksheet.xlsx.rar

أول مرة أفهم عليك أيش تقول 😂 على أية حال أخي @ابو عبد الرحمن اشرف .. لو كنت تقصد أنه لو عطبت نسخة الجداول BE وأردت إعادة الربط بالنخة الاحتياطية .. فأنت تحتاج في هذه الحالة لكود البحث عن نسخة ال BE وإعادة ربطها بنسخة الواجهة .. وهناك عدة أفكار لذلك .. وفي الرابط التالي ستجد فكرتين .. واحدة لأستاذنا جعفر والأخرى للعبد الفقير .. لكيفية تخزين عناوين قواعد البيانات الخلفية ثم إعادة الربط بها حسب حاجة المبرمج :

السلام عليكم و رحمة الله و بركاته اصدقائي الاكارم تحية طيبة في هذا التطبيق سنقوم بتحويل قاعدة بيانات اكسس الى SQL Server طبعا قد يعتبر البعض الموضوع قديم نوعا ما و لكن في هذا التطبيق تم التجريب على ويندوز 11 و اوفيس 2021 32بت و SQL 2005 نسخة مخصصة للعمل على ويندوز 11 قبل البدء لا ننسى ان نقوم باخذ نسخة احتياطية من قاعدة بيانات اكسس و اضافة المكتبات الموضحة في الصورة الى قاعدة البيانات ملاحظة : مكتبة microsoft office 16 object library موجودة في المسار "C:\Program Files (x86) \ Microsoft Office \ root \ vfs \ ProgramFilesCommonX86 \ Microsoft Shared \ OFFICE16\MSO.dll" برنامج SQL Server برنامج إدارة قواعد بيانات SQL برنامج ترحيل قواعد بيانات اكسس الى SQL Server الجزء الاول.pdf 1.bmp

تفضل التعديل راح يضيف نفس الاسم اذا ما وجده ضمن القائمة الاعجمة Replace (1).accdb

لم افهم عليك بالنسبة للطلب الاول .... اذا تم اخفائها فيتم اخفائها في النموذج الرئيسي والفرعي معا ..... وعند الاظهار يظهرها جميعا دفعة واحد ... هل هذا هو المطلوب ؟؟؟؟؟ اما المطلوب الثاني .... فستخدم هذا الكود .... Dim X$ Dim dirr As String Dim i As String i = Nz(Me.k_code, 0) dirr = CurrentProject.Path & "\files\" & i & ".tif" X$ = Dir$(dirr) If X$ = "" Then MsgBox "It does Not exist!", vbExclamation, "Doesn't Exist" Else ShellExecute Me.hwnd, "open", dirr, "", "", 1 End If

وعليكم السلام لا يمكن فتح أى ملف اكسيل يحتوى على أكواد VBA على الموبيل وشكراً !

وعليكم السلام .. لابد ان يكون هناك ملف اكسيل بأى مشاركة لتدعيمها وتوضيح المطلوب بكل دقة وذلك تجنباً لإهدار الوقت !! ولكن عليك بوضع هذا الكود بحدث ThisworkBook حتى يتم تنفيذ طلبك Private Sub Workbook_Open() Worksheets("Main").Activate Range("D5").Select End Sub وهناك كود أخر بالملف المرفوع لك للإنتقال الى خلية معينة من الصفحة الأخرى وسيكون ذلك بمديول عادى Example.xlsm

تفضل أخي @abouelhassan جرب ووافني بالرد . Out-Get_Table_Excel.rar

بما انك لم تقم بالاجابة سوف احاول وضع جميع الاحتمالات الواردة بخصوص السؤال الاول يمكنك اختيار ما يناسبك ووضعه في حدث الشيت ''تنبيه عند تكرار نفس القيمة في العمود اكثر من 10 مرات Private Sub Worksheet_Change(ByVal Target As Range) With Target ' تحديد رقم العمود الهدف If (.Column <> 3) Or .Cells.Count > 10 Then Exit Sub ' تحديد اقصى عدد للتكرار المسموح به If WorksheetFunction.CountIf(Columns(.Column), .Value) > 10 Then 'حدف القيمة المدخلة .ClearContents MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" End If End With End Sub ''''''''''''''''''''''''''''' Private Sub Worksheet_Change(ByVal Target As Range) ' تنبيه عند تجاوز عدد القيم على العمود 10 قيم Dim ws As Worksheet Set ws = Sheet1 Dim LastRow As Long Application.ScreenUpdating = False LastRow = ws.Range("C65000").End(xlUp).Row DataCount = Application.WorksheetFunction.CountA(ws.Range("C:C")) ' تجديد عدد القيم المسموح بها If DataCount > 10 Then MsgBox "لايمكن طباعة أكثر من 10", vbMsgBoxRight + vbOKOnly, "لا يمكن الاستمرار" 'حدف القيمة المدخلة ws.Cells(Rows.Count, "c").End(xlUp).ClearContents End If End Sub اما بخصوص السؤال الثاني Sub test1() ' تلوين المجموعات في النطاق المطلوب اينما وجد التكرار ' قم بظبط الاعدادات بما يناسبك Const FirstRow As Long = 2 ' اول صف Const FirstColumn As String = "C" 'اول عمود Const LastColumn As String = "F" ' اخر عمود Dim dict As Object Dim Ky As Variant Dim rng As Range Dim Arr As Variant Dim Rl As Long Dim Cols As Variant Dim Idx As Long Dim Sp() As String Dim c As Long Dim R As Long 'أضف العديد من الألوان كما يحلو لك Cols = Array(65535, 10086143, 16763904, 15123099, 9359529, 11854022, 32896, 65280, 16711680, 65535, 16711935, _ 16763904, 13434828, 16764057, _ 13408767, 16751052, 10079487) Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") With Worksheets("Sheet1") ' اسم الورقة الخاص بك ' حدف التنسيقات السابقة Columns("C:F").Interior.Pattern = xlNone For c = Columns(FirstColumn).Column To Columns(LastColumn).Column Rl = .Cells(.Rows.Count, c).End(xlUp).Row If Rl >= FirstRow Then Set rng = .Range(.Cells(1, c), .Cells(Rl, c)) Arr = rng.Value For R = FirstRow To Rl If Len(Arr(R, 1)) Then ' تسجيل عنوان كل خلية غير فارغة حسب القيمة dict(Arr(R, 1)) = dict(Arr(R, 1)) & "," & _ Cells(R, c).Address End If Next R End If Next c For Each Ky In dict Sp = Split(dict(Ky), ",") ' شرط عدد التكرار لتنفيد الامر If UBound(Sp) > 1 Then ' تطبيق نفس اللون على نفس القيم For c = 1 To UBound(Sp) .Range(Sp(c)).Interior.Color = Cols(Idx) Next c Idx = Idx + 1 ' إعادة تدوير الألوان إذا كانت غير كافية If Idx > UBound(Cols) Then Idx = LBound(Cols) End If Next Ky End With Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''' '("C") تلوين المجموعات بشرط تكرارها في عمود Sub test2() Dim ws As Worksheet Dim cell As Range Dim myrng As Range Dim clr As Long Dim lastCell As Range Set ws = ThisWorkbook.Sheets("Sheet1") 'النطاق الهدف Set myrng = ws.Range("c2:f" & Range("c" & ws.Rows.Count).End(xlUp).Row) ' نطاق الشرط Set myrng2 = ws.Range("c2:c" & Range("c" & ws.Rows.Count).End(xlUp).Row) With myrng Set lastCell = .Cells(.Cells.Count) End With myrng.Interior.ColorIndex = xlNone clr = 3 For Each cell In myrng If Application.WorksheetFunction.CountIf(myrng2, cell) > 1 Then If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then cell.Interior.ColorIndex = clr clr = clr + 1 Else cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex End If End If Next End Sub ولاستخراج القيم وعدد تكرارها يمكنك استخدام الكود التالي Sub test3() ' عدد القيم المكررة Dim rng As Range Dim var As Variant Dim i As Integer Dim ws As Worksheet Set ws = Sheet1 lr = Range("C65536").End(xlUp).Row Set myrng = ws.Range("M1:N" & Range("c" & ws.Rows.Count).End(xlUp).Row) Application.ScreenUpdating = False myrng.clear ws.[M1] = "القيم" ws.[N1] = "عدد التكرار" i = 0 Set d = CreateObject("Scripting.Dictionary") For Each rng In ws.Range("c2:f" & lr) If rng <> "" Then If d.exists(rng.Value) Then d(rng.Value) = d(rng.Value) + 1 Else d.Add rng.Value, 1 End If End If Next For Each var In d.keys '(M) سيتم وضع الاسماء في العمود '(N)وعدد تكرارها في العمود Range("M" & (i + 2)) = var Range("N" & (i + 2)) = d(var) i = i + 1 Next myrng.Borders.Weight = xlThin Range("N2:N" & lr).Font.Color = 255 Set d = Nothing Application.ScreenUpdating = True End Sub واليك الملف عليه جميع الاكواد اختر ما يناسبك بالتوفيق countif_V2.xlsm countif_V3.xlsm

عليكم السلام ورحمة الله وبركاته ما رأيك بكود Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub ورقة عمل Microsoft Excel جديد (2).xlsm

تفضل جرب Private Sub TextBox26_Change() Dim CelF As Range, LigF As Long Set ws = ActiveWorkbook.Sheets("Data") With ws Set lst = ws.ListObjects("الجدول1") If lst.ShowAutoFilter Then lst.ShowAutoFilter = False End If Set CelF = ws.Range("Find").Find(What:=Me.TextBox26, LookIn:=xlValues, LookAt:=xlWhole, _ SearchDirection:=xlNext, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False) If Not CelF Is Nothing Then LigF = CelF.Row Label1.Caption = ws.Range("B" & LigF) Label2.Caption = ws.Range("C" & LigF) Label3.Caption = ws.Range("E" & LigF) Label4.Caption = ws.Range("D" & LigF) Else For S = 1 To 3 Me("Label" & S) = Empty Next S End If End With Label2 = Format(Label2, "dd/mm/yyyy") Label2.BackColor = &H8000000F End Sub TEST V1.xlsb

السلام عليكم و رحمة الله شاهد هذا المرفق ربما يكون هو طلبك يمكنك التعديل عليه بما يتوافق مع رغباتك ViewPicts.rar

Insert Module1 and paste the following code Option Explicit Private Sub ColorBySubject() Const STARTROW As Long = 8, STARTCOL As Long = 5, COLSNUM As Long = 4 Dim x, aCols, wsMarks As Worksheet, wsColors As Worksheet, rng As Range, sMarks As String, sQuote As String, sCell As String, n As Long, m As Long, ii As Long Application.ScreenUpdating = False With ThisWorkbook Set wsMarks = .Worksheets(1) Set wsColors = .Worksheets(2) End With Set rng = wsColors.Range("S8:S15") x = Application.Match(wsColors.Range("E3").Value, rng, 0) If Not IsError(x) Then sMarks = wsMarks.Name sQuote = WorksheetFunction.Rept(Chr(34), 2) n = wsMarks.Cells(Rows.Count, "C").End(xlUp).Row - 3 aCols = Array(5, 8, 11, 14, 17, 20, 23, 26) For m = 1 To 3 sCell = ColumnToLetter(aCols(x - 1) + m - 1) & "4" With wsColors If m <> 3 Then For ii = 4 To 1 Step -1 With .Cells(STARTROW, m * COLSNUM - ii + STARTCOL).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=" & ii & ",""0""," & sQuote & "))" End With Next ii Else With .Cells(STARTROW, 13).Resize(n) .Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & ">=3.5,""0""," & sQuote & "))" .Offset(, 1).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">=2.5," & sMarks & "!" & sCell & "<3.5),""0""," & sQuote & "))" .Offset(, 2).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(AND(" & sMarks & "!" & sCell & ">1," & sMarks & "!" & sCell & "<2.5),""0""," & sQuote & "))" .Offset(, 3).Formula = "=IF(" & sMarks & "!" & sCell & "=" & sQuote & "," & sQuote & ",IF(" & sMarks & "!" & sCell & "=1,""0""," & sQuote & "))" End With End If End With Next m End If Application.ScreenUpdating = True End Sub Function ColumnToLetter(ByVal columnNumber As Long) As String If columnNumber < 1 Then Exit Function ColumnToLetter = UCase(ColumnToLetter(Int((columnNumber - 1) / 26)) & Chr(((columnNumber - 1) Mod 26) + Asc("A"))) End Function Then in worksheet module (Colors) [The worksheet that has the data validation list], paste the following code Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$E$3" Then Application.Run "Module1.ColorBySubject" End If End Sub

تفضل استاذ @أغيد طلبك في التقرير (Report1). ولا تنسى طلبي . تحويل صفوف الجدول الى اعمدة -1.accdb

جرب المرفق .. تمت كتابة المعادلة بواسطة الذكاء الاصطناعي 🙂 الوقت.xls

عذراً خطأ طباعي Book1.xlsm

وعليكم السلام ورحمه الله وبركاته For Each w In ThisWorkbook.Worksheets If w.Name <> "ورقة7" And w.Name <> "ورقة8" Then co1.AddItem w.Name End If Next w

تفضل طلبك و لا تنساني بدعوة طيبة مثال.accdb

السلام عليكم ورحمه الله وبركاته وبها نبدأ تفضل ضع هذا الكود في حدث الشيت المطلوب Private Sub Worksheet_Change(ByVal Target As Range) Dim X As Range Application.EnableEvents = False For Each X In Target If X.Row > 3 Then If X.Column = 2 Then If X.Value = "ok" Then X.Offset(0, -1).Value = Date ElseIf X.Column = 3 Then If X.Offset(0, -1).Value = "ok" Then X.Offset(0, 1).Value = X End If End If Next X Application.EnableEvents = True End Sub

Try this code Sub Test() Const NROWS As Long = 10 Dim a, ws As Worksheet, sh As Worksheet, r As Range, s As String, m As Long, i As Long With ThisWorkbook Set ws = .Worksheets(1): Set sh = .Worksheets(2) End With s = Join(Array(Chr(199), Chr(225), Chr(209), Chr(222), Chr(227)), Empty) m = 2 Set r = sh.Columns(2) a = FindNext(s, r) If Not IsEmpty(a) Then For i = LBound(a) To UBound(a) With sh.Range("A" & a(i)).CurrentRegion.Offset(1) .ClearContents: .Borders.Value = 0 End With sh.Range("A" & a(i) + 1).Resize(NROWS).Value = Evaluate("ROW(1:" & NROWS & ")") sh.Range("B" & a(i) + 1).Resize(NROWS).Value = ws.Range("A" & m).Resize(NROWS).Value m = m + NROWS Next i End If End Sub Function FindNext(ByVal strFind As String, ByVal rng As Range) Dim arr(), myRng As Range, iRow As Long, k As Long With rng Set myRng = .Find(What:=strFind, After:=rng.Cells(rng.Cells.Count), LookIn:=xlValues, LookAt:=xlPart) If Not myRng Is Nothing Then iRow = myRng.Row Do k = k + 1 ReDim Preserve arr(1 To k) arr(k) = myRng.Row Set myRng = .FindNext(myRng) Loop Until myRng.Row = iRow End If End With FindNext = arr End Function Note the following The code will find the rows that has the string `NUMBER` then to copy 10 numbers from the first worksheet and so on But the code is limited to the headers in the second worksheet so not all the numbers in the first worksheet will be copied

الأصدقاء الاكارم السلام عليكم و رحمة الله و بركاته اعتقد ان الموضوع قديم نوعا ما و لكن الكل يعاني من مربعات الحوار حفظ و فتح ملف ( و انا واحد منهم 😅) الحل موجود هنا 🙂 OpenSaveFileDialog.rar

وعليكم السلام ورحمة الله وبركاته .. 🙂 نعم ممكن أخي @moho58 بكل سهولة .. وبدون الحاجة للدخول في تعقيدات الاستعلام الجدولي .. مادام أن الشكل ثابت لا يتغير بزيادة في عدد السجلات المعروضة .. وإنما التغيير يكون أسبوعيا .. فيمكنك إنشاء جدول وتكون الحقول هي نفس عدد الخلايا التي في الشكل الذي عندك لكل سجل .. هكذا : وبعدها سيكون الموضوع بسيط جدا .. مجرد تنسيق للخلايا في النموذج هكذا : والنتيجة النهائية في النموذج : ولو أردت جعل المادة والمعلم تظهر تلقائيا بدل كتابتها كل مرة .. ضعها في خاصية القيمة الافتراضية عند تصميم الجدول الملف المرفق : جدول أسبوعي.accdb

تفضل لازم تحدد الحقل الي لما تضغط على رقم 1 يكتب داخل الحقل رقم 1 و كذلك لبقية الارقام و فوق الارقام حطيت لك مربح يبين الحقل المحدد اتمنى تناسبك الفكرة alizaeyd.accdb

تم اكمال المثال حسب الأمر بالتسلسل واكتفيت بالصور والمستندات فقط آمل من اخواني التجربة وارسال مرفق لأكثر من شخص ، والافادة بالنتيجة لتفادي المشكلات ان وجدت واعتماده كما اطلب من اخوتي الخبراء فحص الزمن ( sleep) وضبطه ان لزم حتى تظهر عملية الارسال انسيابية محكمة .. لانه حاليا ومن مشاهدتي يوجد تفاوت في السرعة والبطء خلال تنقل الأمر sendwatsWeb2.mdb

التعامل مع الاستعلام الجدولي محدود .. لذا يصعب تطبيق فصل الجمع على مستوى افقي انظر كيفية الفصل في المثال .. اصبح لكل منتج سطر حسب السنة نستطيع القول انهما استعلامان ضمن استعلام واحد تستفيد من توظيفه جيدا في التقرير اذا تم العرض حسب المنتج بمعنى الاستعلام عن منتج محدد خلال السنتين على مستوى المحافظات ايضا يمكن جلب القيم منه الى خلايا غير منضمة بمعلومية ( السنة / المحافظة / المنتج ) مثال اوفيسنا اجمالي المبيعات الشهرية3.mdb

لمشاهدة كيفية استخدام البرنامج اضعط على الرابط

تفضل أخي برنامج حصلته عندي من أعمال منتدانا أفسينا الاستبيان---2003.rar

البرنامج كما ذكرت لك

تعمل فولدر وليكن (icons) ثم تعبئ به كل الأيكونات التي تريدها تجيبها من جوجل بامتداد (ico.) أو (.bmp) وبعطيك برنامج يصنع أيكونات فقط افلت أي صورة حتى صورتك . واحفظها بالفولدر الذي أنشأته . ثم تستدعي الأيكون من فورم الأكسس عادي . ولو مش عارف كيف نشرح . المهم تقرأ البرنامج وين طريقة الحفظ . واليك البرنامج ووافني بالرد . ToYcon.rar

وعليكم السلام ورحمة الله وبركاته إليك هذا الملف يمكن يفيدك إن شاء الله الفكرة قريبة من كشوف مناداة اللجان في الاختبارات وهذا يمكن طباعته يدويا ويمكن اضافة كود لطباعة الكل تلقائيا مناداة ولجان لجنة.xls