عبدالله بشير عبدالله

وعليكم السلام ورحمة الله وبركاته الأخ الكريم صاحب الكلمة الطيبة والمشاعر النبيلة، الفاضل / algammal أسعد الله قلبك كما أسعدتنا بكلماتك التي فاحت منها الطيبة والوفاء، ووالله إنها لوسام على صدورنا، ودافع لنا لنستمر في العطاء ما حيينا. نحن لم نقدّم إلا واجبًا يسيرًا، وما نحن إلا تلاميذ في هذا الصرح الطيب، ننهل ونتعلم ونتشارك. وسعادتنا الحقيقية أن نرى ثمرة هذا التعاون في نفوس طيبة مثلكم. بمناسبة عيد الأضحى المبارك، أتقدّم إليك وإلى جميع الإخوة والأعضاء الكرام بأطيب التهاني والتبريكات، أعاده الله علينا وعليكم بالخير واليمن والبركات، وتقبّل الله طاعاتكم، وبلغكم منازل الأبرار ‏، وأكرمكم بالعفو والعافية والغفران ، ووفقكم لما يحب ربنا ويرضاه ، لكم مني خالص المحبة والتقدير،

وعليكم السلام ورحمة الله وبركانه لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت اليك التعديل Private Sub TextBox1_Change() ListBox1.Clear Application.ScreenUpdating = False Dim ws As Worksheet: Set ws = Sheets("add") Dim lr As Long, c As Range, b As Integer, k As Long Dim arrData() As Variant Dim i As Long, j As Long lr = 0 For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) b = InStr(1, c.Value, TextBox1.Value, vbTextCompare) If b > 0 Then lr = lr + 1 ReDim Preserve arrData(1 To 2, 1 To lr) arrData(1, lr) = c.Value arrData(2, lr) = c.Offset(0, 4).Value End If Next c With ListBox1 .ColumnCount = 2 .ColumnWidths = "100;100" If lr > 0 Then .List = Application.Transpose(arrData) End If End With Application.ScreenUpdating = True End Sub في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم arrData(2, lr) = c.Offset(0, 4).Value كنا يمكنك من تعديل عرض العمود بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني .ColumnWidths = "100;100" ارجو ما قدمته ان يكون طلبك كل عام وانت بخير المرحليات أوفيسنا.xlsm

السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm

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

وعليكم السلام ورحمة الله وبركاته 4 طرق لمسح البيانات 1- زر به كود مسخ البيانات (جديد) يقوم الزر بنفس وظيفة الخلية الفارغة 2- اخنيار الخلية الفارغة من E5 (بعد عمل زر المسخ ليس لها ضرورة ) 3- الخروج من شيت SEARCH ثم العودة اليه 4- النقر مرتين في اي خلية في شيت SEARCH وايسرها كما تفضلتم زر المسح او النقر مرنين كما انوه ان تحديث البيانات اظافة وظيفة جديدة ..... الخ الى شيت DATA او معاشات يتم تلقائيا مع الانتباه لزيادة مدى البيانات للقائمة من التحقق من صحة البيانات انمنى اتى قدمت ما بقيد وما زال الباب مفتوحا لمفترحاتكم او ملاحظاتكم وكل عام وانتم بالف خير طريقة اخرى للبحث معدلة7.xlsb

وعليكم السلام ورحمة الله وبركاته ملفك لا بحتوى على اي كود تم عمل كود لطلبك والكود مرن يطبع الى اخر صف قيه بيانات Sub PrPAGES() Dim printWS As Worksheet Dim lastRow As Long Dim printRange As Range Set printWS = ThisWorkbook.Sheets("S1") lastRow = printWS.Cells(printWS.Rows.Count, "A").End(xlUp).Row Set printRange = printWS.Range("A1:C" & lastRow) printWS.PageSetup.PrintArea = printRange.Address printWS.PrintOut End Sub 1نموذج.xlsb

السلام عليكم ورحمة الله وبركاته عذرا لتأخرى في الرد حسب الصورة المرفقة مع ردكم الكريم اظافة عنصر فارغ في القائمة e5 وبناء عليه تكون b10&g10 فارغتان تم التعديل و يمكنك تعديل نطاق القائمة كما تشاء يمكنك الاسنغناء عن زر انقر هنا للبحث وإذا لاحظت أي شيء يحتاج تعديل أو عندك أي فكرة تحب نضيفها، أنا حاضر بأي وقت، لك كل الود والتقدير طريقة اخرى للبحث معدلة6.xlsb

وعليكم السلام ورحمة الله وبركاته اليك الكود المتاسب لطلبك Sub call1() Sheets("ff").Range("D3:U3").ClearContents Dim i As Integer For i = 1 To Sheets.Count Sheets("ff").Cells(3, 3 + i) = Sheets(i).Name Next i End Sub

السلام عليكم ورحمة الله وبركاته جرب التعديل التالى حسب طلبكم الاخير وفقكم الله طريقة اخرى للبحث معدلة5.xlsb

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

وعليكم السلام ورحمة الله وبركاته كمثال حساب1 =SUMIF($E$5:$E$1000; J5; $F$5:$F$1000) هي معادلة Excel تستخدم دالة SUMIF لجمع القيم بناءً على شرط معين تركيب الدالة SUMIF(range, criteria, [sum_range]) range: النطاق الذي يحتوي على القيم التي سيتم فحصها بناءً على الشرط. criteria: الشرط الذي يجب أن يتحقق لكي تتم عملية الجمع. sum_range: (اختياري) النطاق الذي سيتم جمع القيم منه إذا تحقق الشرط. شرح الدالة $E$5:$E$1000 → هذا هو نطاق الشرط: Excel سيبحث فيه عن القيم التي تساوي قيمة الخلية J5. J5 → هذا هو الشرط: نبحث عن الخلايا في العمود E التي تحتوي على نفس القيمة الموجودة في J5. $F$5:$F$1000 → هذا هو نطاق الجمع: إذا تم العثور على تطابق في العمود E، سيتم جمع القيمة المقابلة له في نفس الصف من العمود F. يوجد يديل اخر لها نفس النتيجة =SUMPRODUCT(($E$5:$E$1000=J5) * $F$5:$F$1000) ملاحظة / النطاق الى الصف 1000 يمكن زيادته او تقليله وجعلته 1000 حسب قولك ان العدد يمكن ان يكون اكثر اتمنى ان تجد ما يفيد في الشرح اعلاه لك كل التقدير والاحترام

وعليكم السلام ورحمة الله وبركاته جزاكم الله خيرًا على كلماتكم الطيبة ومشاعركم النبيلة، التي أعتز بها كثيرًا. لا يسعني إلا أن أبادلكم الدعاء بمثله وأكثر، وأسأل الله أن يديم بيننا المحبة والاحترام، وأن يوفقنا وإياكم لما فيه الخير والصلاح لكم ما طلبتم في انتظار ردكم من خلال تجربتكم للملف طريقة اخرى للبحث معدلة2.xlsb

وعليكم السلام ورخمة الله وبركاته اليك الملف حسب فهمى لطلبك الحساب.xlsx

السلام عليكم جميعا ورحمة الله وبركاته الاستاذ الفاضل algammal بداية من اخر استفسار لكم هذا الزر غير ضرورى قمت بعمله بداية ثم نسيت ان احذفه بالتسبة للقوائم المتسدلة جعلتها مرنه بحيث يتم احضار البياتات الفعلية من العمود فقط فمثلا حاليا سن الخروج كلها 60 ستجد في القائمة 60 فقط واذا اضفت مثلا اي سن خروج اخرى في شيت معاشات او DATA ستجدها في القائمة وكذلك لباقى القوائم الاخرى لها تفس الخاصية اعتقد تقصد كل المهن الموجودة في الخلية E5 وليس B5 هذا حسب فهمى لطلبكم وفي اتنظار ملاحظايكم كما احب ان اتوه فكرة الاستاذ @محمد هشام. رائعة جدا وتحتاج الى تعديل في الكود لكي يتم البحث في شيت معاشات اظافة الى شيت DATA لان البياتات في شيت معاشات تم ترحيلها من شيت DATA الى معاشات وتم حذفها من شيت DATA بعد الترحيل في اتنظار تعديل الكود وفقه الله وجزاه الله خيرا لكم جميعا اطيب التحيات طريقة اخرى للبحث معدلة1.xlsb

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل algammal جزاك الله كل خيرا على ثتاؤك ودعائك لي الاستاذ الفاضل Foksh تحية لك ولاخواننا في منتدى الاكسس بعد اذنكما ساطرح فكرة اخرى لطلب حبيبنا algammal حسب فهمى لطلبكم انكم تريدون البحث باسم الموظف او الرقم الوطني او من وظيفتهم طبيب كمثال اذا كان هذا الطلب فليس من الضرورى تجميع الاسماء في شيت واحد لان هذا سيزيد من حجم الملف وتكرار بيانات ليس لها ضرورة الفكرة كود يقوم بالبحث في شيت معاشات وشيت data باستخذام النطاق a5:m5 في شيت search ونتيجة البحث ينم وضعها في نفس الشيت بداية من A10 تم عمل قائمة بالاسماء بدل كنابنها ويتم تحديثها يدويا بواسطة زر وتتحدث تلقائيا عتد الانتهاء من البحث الملف المرفق يوضح الفكرة لكما ولكل اعضاء المنتدى وافر التقدير والاخترام طريقة اخرى للبحث.xlsb

وعليكم السلام ورحمة الله وبركاته اظافة الى اقتراح معلمنا ابوعيد يمكن عن طريق كود قي حدث الورقة قلم 1.xlsb

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

السلام عليكم ورحمة الله وبركاته أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه. أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا. كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal. تحياتي واحترامي لك أخي العزيز، وبعد إذن معلمنا، هذه محاولة متواضعة لتنفيذ طلب أخينا العزيز، حسب ما فهمته من سؤاله. أتمنى أن تقوم بتجربة الحل، وإذا كان هناك أي تعديل أو توضيح إضافي، فأنا على أتم الاستعداد . مع خالص التحية والتقدير لكما ولكل منابعى المنتدى، الكود Sub ترحيل_البيانات() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim startTime As Double: startTime = Timer Dim sheetName As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..." End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub dataArray = wsMain.Range("A5:M" & lastRow).Value For i = 1 To UBound(dataArray, 1) sheetName = Trim(dataArray(i, 5)) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True Dim key As Variant, rowIndex As Long For Each key In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = key wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False wsMain.Rows("3:4").Copy wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For rowIndex = 1 To UBound(dataArray, 1) If Trim(dataArray(rowIndex, 5)) = key Then wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow) targetRow = targetRow + 1 End If Next rowIndex For i = 1 To wsMain.UsedRange.Rows.Count If i <= wsNew.UsedRange.Rows.Count Then wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight End If Next i For i = 1 To 13 wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i Next key wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume CleanUp End Sub الملف ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb

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

وعليكم السلام ورحمة الله وبركاته "جزاك الله خيرًا على دعائك الطيب، أسأل الله أن يرزقك أضعاف ما دعوت لي، وأن يبارك لك في عمرك وعملك." هذا الكود يعمل في شيت معاشات لو ربطته بزر لوحده ولكن دمجه مع كود الترحيل يحناج الى وضعه في المكان المناسب وبطريقة مناسبة بحيت يصبح الكود بهذا الشكل With wsTarget.Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With حيث wsTarget تعنى شيت معاشات حيث قمنا بتعريفها في بداية الكود بدلا من اعادة كتابة اسم الشيت كل مرة Set wsTarget = ThisWorkbook.Sheets("معاشات") اليك الملف بعد اظافة محاداة الاسماء لليمين اتمنى انى قدمت لك ما بفيد ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 7.xlsb

وعليكم السلام ورحمة الله وبركاته لديك الحق الجزء الخاص بحدود الصف الثالت With ws.Range("C3,E3,H3,J3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Bold = True .NumberFormat = "0" .Borders.Weight = xlThin End With .Borders.Weight = xlThin وزن الخط رفيع يتم تعديله الى .Borders.Weight = xlMedium وزن الخط منوسط كذلك يجب تعديل With ws.Range("C3,E3,H3,J3") لانها نشمل خلايا معينة لتحديدها ويتم تعديلها لتشمل النطاق With ws.Range("B3:J3") الملف بعد التعديل ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 7.xlsb لك كل الود والاحترام

السلام عليكم حسب قهمى لطلبك ترتيب حسب اللون.xlsb

وعليكم السلام ورحمة الله وبركاته قم بتحميل الملف في المشاركة السابقة يومك طيب ومبارك

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

وعليكم السلام ورحمة الله وبركاته بعد اذن استاذنا محمد هشام جرب التعديل التالي تفس الكود والتغديل في السطر arr(i - 1) = WS.Cells(i, "I").Value بالسطر arr(i - 1) = CStr(WS.Cells(i, "I").Value) الكود كاملا Option Explicit Sub FilterByNames() Dim WS As Worksheet, arr(), i&, n&, filterRange As Range Set WS = Sheets("Sheet1") If WS.AutoFilterMode Then WS.AutoFilterMode = False n = WS.Cells(WS.Rows.Count, "I").End(xlUp).Row If n < 2 Then Exit Sub ReDim arr(1 To n - 1) For i = 2 To n arr(i - 1) = CStr(WS.Cells(i, "I").Value) Next i Set filterRange = WS.Range("B6").CurrentRegion With filterRange .AutoFilter Field:=2, Criteria1:=arr, Operator:=xlFilterValues End With End Sub