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

وعليكم السلام-تفضل هذا الكود Sub ColorPaletteDialogBox() Dim lcolor As Long If Application.Dialogs(xlDialogEditColor).Show(10, 0, 125, 125) = True Then 'user pressed OK lcolor = ActiveWorkbook.Colors(10) ActiveCell.Interior.Color = lcolor Else 'user pressed Cancel End If End Sub

حل آخر Sub test2() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4) For i = 1 To UBound(a) If a(i, 1) <> "" Then If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If: End If Next End Sub

يمكنك تجربة هذه المحاولة بالمعادلات بدلا من تصدير النتائج في شيت جديد يمكنك كتابة مصطلح البحث والحصول على النتائج في شيت النتائج أهم شيء معادلة المسلسل في شيت البيانات data لأن معادلة البحث vlookup تعتمد عليها بالتوفيق فلترة نتائج البحث في شيت جديد.xls

بعد ادن الاستاد الكبير @ابراهيم الحداد اليك حلول اخرى لاثراء الموضوع لا اكثر Private Sub CommandButton1_Click() Dim x, A(), i&, F&, Y&, lr&, last&, Wdata As Variant Dim WSdest As Worksheet: Set WSdest = Sheets("اعداد قوائم المدرسة") last = WSdest.Cells(Rows.Count, "a").End(xlUp).Row + 1 Application.ScreenUpdating = False WSdest.Range("A3:L" & last).ClearContents For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) lr = Wdata.Range("B" & Rows.Count).End(xlUp).Row x = Wdata.Range("B3:L" & lr) For i = 1 To UBound(x, 1) Y = Y + 1: ReDim Preserve A(1 To UBound(x, 2), 1 To Y) For F = 1 To UBound(x, 2) A(F, Y) = x(i, F) Next Next With WSdest WSdest.Range("b3").Resize(Y, UBound(A, 1)) = Application.Transpose(A) WSdest.Range("a3") = 1 WSdest.Range("a3:a" & WSdest.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear End With Next Wdata Application.ScreenUpdating = True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Sub copy_data() Dim dlgR As Integer, dlgi As Integer, Wdata As Variant Dim ws As Worksheet: Set ws = Sheets("اعداد قوائم المدرسة") With ws Application.ScreenUpdating = False dlgR = .Range("A" & Rows.Count).End(xlUp).Row + 1 ws.Range("A3:l" & dlgR).ClearContents End With For Each Wdata In Sheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) dlgR = ws.Range("b" & Rows.Count).End(xlUp).Row With Wdata dlgi = .Range("b" & Rows.Count).End(xlUp).Row .Range("b3:l" & dlgi).Copy ws.Range("b" & dlgR + 1) ws.Range("a3") = 1 ws.Range("a3:a" & ws.Range("b" & Rows.Count).End(xlUp).Row).DataSeries , xlDataSeriesLinear End With Next Application.ScreenUpdating = True End Sub اما بالنسبة ل t = Timer يمكنك الغاء الرسالة في اخر الكود فقط MsgBox Round(Timer - t, 2) قوائم المدرسة 2.xlsm

السلام عليكم و رحمة الله اجعل الكود هكذا Sub CallData() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, y As Long Dim C As Range, Temp() Dim Counter As Long Set ws = Sheets("اعداد قوائم المدرسة") t = Timer Application.ScreenUpdating = False '----------------- On Error Resume Next ws.Range("A3:L1000").ClearContents For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) LR = Sh.Range("B" & Rows.Count).End(3).Row Counter = Counter + LR Next '----------------- ReDim Preserve Temp(Counter, 12) y = 0 For Each Sh In Worksheets(Array("اعداد قوائم اولى", "اعداد قوائم ثانية", "اعداد قوائم ثانية ثالثة")) For Each C In Sh.Range("B3:B" & LR) If Len(C.Value) > 0 Then Temp(y, 0) = y Temp(y, 1) = C.Value Temp(y, 2) = C.Offset(0, 1) Temp(y, 3) = C.Offset(0, 2) Temp(y, 4) = C.Offset(0, 3) Temp(y, 5) = C.Offset(0, 4) Temp(y, 6) = C.Offset(0, 5) Temp(y, 7) = C.Offset(0, 6) Temp(y, 8) = C.Offset(0, 7) Temp(y, 9) = C.Offset(0, 8) Temp(y, 10) = C.Offset(0, 9) Temp(y, 11) = C.Offset(0, 10) y = y + 1 End If Next Next '----------------- If y > 0 Then ws.Range("A2").Resize(y, UBound(Temp, 2)).Value = Temp '----------------- Application.ScreenUpdating = True MsgBox Round(Timer - t, 2) End Sub

استاذ ابو خليل..انا لاحظت المرفق سابقا تركيبة الملف حسبما اظن هو بأدخال بيانات جديدة ومسح القديم ..يعني لاتبقى اي بيانات سابقة ...بصراحة هذا امر غريب!!

السلام عليكم وبها نبدأ ارفق ملف اخى @UNFOOAAN

@samycalls2020 @عبدللرحيم أنا ممتن جداً لكم على تواصلكم باسمي ونيابة عن كافة الشعب المغربي ⁦‪أشكركم‬⁩ فرداً فرداً ⁦‪على‬⁩ ⁦‪تعازيكم‬⁩ ودعمكم لنا في هذا المصاب الجلل، و أقول للجميع شكر الله سعيكم وعظم أجركم وجزاكم الله عنا خير الجزاء ولا اراكم الله مكروها بأنفسكم ولا عزيز عليكم وغفر الله لأمواتنا وامواتكم ومن قال امين سائلا المولى عز وجل أن يتغمدهم بواسع الرحمة والمغفرة، وأن يلهم ذويهم الصبر والسلوان، وأن يشفي الجرحى والمصابين .

السلام عليكم ورحمة الله وبركاته اشكرك جزيل الشكر مرة أخرى أخي أ. محمد يوسف ابو يوسف وبارك الله فيك وتمنياتي لك بالتوفيق والنجاح الدائم

السلام عليكم ورحمة الله وبركاتة بالفعل ماتقوله صحيح تفضل المحترف - 2023-9-م.xlsm

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

عليكم السلام ربما Sub test() Dim a Dim i&, c& a = Sheets("sheet1").Cells(5, 1).CurrentRegion.Columns(1) With CreateObject("VBScript.RegExp") .Global = True .Pattern = "جميلة" For i = 1 To UBound(a) If .test(a(i, 1)) Then Sheets("جميلة").Cells(c + 1, 1) = a(i, 1) c = c + 1 End If Next End With End Sub

الاستاذ الفاضل محى الدين ابو البشر الف شكر لحضرتك الكود يعمل و ينفذ المطلوب الف الف شكر لحضرتك و استاذنا الفاضل ابراهيم الحداد الف شكر لحضرتك زادكم الله من علمه و فضله و حفظكم بحفظه

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

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

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

تأكد من مسار الحفظ عندك .... انظر ....

السلام عليكم ورحمة الله وبركاتة تفضل المحترف - 2023م.xlsm

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

عليكم السلام ورحمة الله وبركاته يمكنك استعمال هذه المعادلة في L6 =IF(H6>0,VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0),0),0) وهذه المعادلة في N6 =IF(AND(H6>0,OR(S6="ض نقل",S6="نقل")),VLOOKUP(C6,$T$5:$AI$100,MATCH(B6,$T$5:$AI$5,0)+1,0),0) لاحظ استعمال match لجلب ؤقم العمود بدلالة رقم أمر التوريد بالتوفيق

السلام عليكم ورحمة الله وبركاته لا يوجد ما هو أهم من العرفان بالجميل والشكر الجزيل الى كل من قدم لنا العطاء وسهل علينا الصعوبات. بارك الله فيك وزادك علما @دروب مبرمج كانت الطريقة رائعة ومميزة جدا.

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

تفضل اخي تم تعديل الاكواد لتتناسب مع طلبك . Private Sub Worksheet_Change(ByVal Target As Range) ''''''''''''''''''''''''''' الخزينة 1 '''''''''''''''''''''''''''''''' On Error Resume Next ' 'اظافة شرط الفلترة لزر التصفية If Not Intersect(Target, Range("j3")) Is Nothing Then Add_text If Not Intersect(Target, Range("D3")) Is Nothing Then Dim LRow As Long, Réf As Range, data As Range Dim WSData As Worksheet: Set WSData = ThisWorkbook.Sheets("الخزينة1") 'اسم عمود البحث Col = WSData.Range("D3").Text 'خلية القائمة المنسدلة Set cel = [j3] Application.ScreenUpdating = False Application.Calculation = xlManual 'الغاء الفلترة WSData.ShowAllData 'نطاق البحث Set Réf = WSData.Range("D6:O6").Find(Col) If Not Réf Is Nothing Then On Error Resume Next ' افراغ البيانات السابقة WSData.Range("Ad7:Ad" & Range("Ad7").End(xlDown).Row).ClearContents LRow = WSData.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row 'نسخ العمود الهدف WSData.Range(WSData.Cells(7, Réf.Column), WSData.Cells(3325, Réf.Column)).Copy With WSData 'لصق .Range("AD7").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'ترتيب ابجدي (رقمي) WSData.Range("AD7:AD" & LRow).Sort Key1:=Range("AD7"), Order1:=xlAscending, Header:=xlNo 'ازالة الفراغات WSData.Range("ad7:ad" & LRow).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp 'ازالة التكرار WSData.Range("AD7", .Cells(.rows.Count, 30).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo [j3].NumberFormat = [AD7].NumberFormat End With ' اظافة قائمة منسدلة مطاطية Set data = Range(Range("Ad7"), Range("Ad" & rows.Count).End(xlUp)) With cel.validation .Delete .Add Type:=xlValidateList, Formula1:="=" & data.Address & "" [j3] = [AD7] End With End If End If [d6].Select Application.CutCopyMode = False Application.Calculation = xlAutomatic On Error GoTo 0 End Sub الخزينة6.xlsb

وعليكم السلام كحل مبدئي احذف الأسطر الزائدة في الجدول ومن خصائص الجدول في الأكسل أنه إذا كتبن في الخلية أسفله يضيف سطر جديد ويضمن الصيغ للرفع2.xlsx

تفضل هذا مثال قمت بإعداده للإتصال بقاعدة البيانات يجب تقسم قاعدة البينات لديك في مشروعك ثم الاتصال بقاعدة البيانات في السيرفر او الجهاز المحلي الذي ستحتفظ بقاعدة البيانات به ( الجداول ) في المثال لدينا ثلاث قواعد بيانات + الواجهة من خلال الواجهة سنقوم بالتالي - انشاء مجلد للنسخة الاحتياطية - سيتم حفظ نسخة جديدة عند تسجيل كل قاعدة بيانات - يجب بعد تسجيل النسخة ان تقوم بالإتصال بقاعدة البيانات تم ترقم الخطوات ليسهل التجربة و لكن يجب فك الضغط اولا قبل الاستخدام بعد تسجيل النسخة و الاتصال بها ستكون بهذا الشكل StrData.zip

عموما في مشاركتك الثانية والتي تقول ان هذا الكود خاص بالحصص المتتالية Public Function MAKEIT1() Call TSFERTABLE1 Dim mada As Recordset Dim MOALEM As Recordset Dim TABLE As Recordset On Error Resume Next '_____________________ Set mada = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المادة] ORDER BY [متتالية] DESC,[الصف]", dbOpenDynaset) Set TABLE = CurrentDb.OpenRecordset("teacher class1", dbOpenDynaset) '_____________________ mada.MoveFirst Do While mada.EOF = False Set MOALEM = CurrentDb.OpenRecordset("SELECT * FROM [بيانات المعلم] WHERE [الصف] = " & mada![الصف] & " AND [المادة] =" & "'" & mada![المادة] & "'" & " ORDER BY [الفصل]", dbOpenDynaset) MOALEM.MoveFirst Do While MOALEM.EOF = False TABLE.FindFirst "[رقم]=" & MOALEM![رقم] Call RECORDHSA(MOALEM, mada, TABLE) MOALEM.MoveNext Loop mada.MoveNext Loop End Function هل تسطيع طباعة MOALEM قبل عملية التوزيع او اعطيني بيانات هذا الجدول قبل التوزيع هنا ستعرف لماذا لا يعتمد الحصتان المتتالبتان

وعليكم السلام ..بما انك لم تقم برفع ملف ,,فكان عليك استخدام خاصية البحث بالمنتدى فطلبك تكرر كثير جداً وشوف بنفسك : وده كمان مثال بملف مرفق لك وكلمة السر لإظهار الصفحات : 123 اخفاء الشيتات و ترك الشيت الرئيسي هو الظاهر كود اخفاء الشيتات عدا شيت محدد اخفاء الصفحات تلقائيا اخفاء أوراق العمل وعدم اظهارها فورم_كود اظهار و اخفاء للصفحات Sheets Hidding - 2.xlsm

السلام عليكم لم أكن اعلم انه يوجد معادلات جاهزة بالإكسل للتباديل وللتوافيق PERMUT و COMBIN ستسهل عليك كثيرا أنظر الرابط التالي http://www.officena.net/ib/index.php?showtopic=26071&st=0&p=123827&hl=%CA%E6%C7%DD%ED%DE&fromsearch=1&#entry123827