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

جزاكم الله خيرا اخى ابو يوسف @محمد حسن المحمد جزاكم الله خيرا اخي @محمد يوسف ابو يوسف جزاكم الله خيرا علي التنبيه وهذا نص تقرير اخى ابو يوسف محمد حسن المحمد جزاه الله خيرا السلام عليكم ورحمة الله وبركاته إخوتي أساتذتي الكرام: تحية طيبة وبعد أرى أن هذا الموضوع وإن كان في ظاهره يخص سؤال أو أكثر في الإكسل،إلا أنه في حقيقة الأمر يفتح باباً واسعاً لما لا يرضي الله وهو ما يخالف برأيي منهجنا كمسلمين فقد ثبت عن النبي ﷺ أنه قال: من اقتبس شعبة من النجوم؛ فقد اقتبس شعبة من السحر، زاد ما زاد فتعلم التنجيم لمعرفة الحوادث، ودعوى علم الغيب هذا منكر عظيم وإنما هي كما قال الله -جل وعلا- زينةٌ للسماء، ورجوم للشياطين، وعلامات يهتدى بها، فمن تعلمها لمعرفة الطرق، وأوقات الحراثة، وأشباه ذلك مما هو معروف؛ فهذا لا بأس به، أما أن يتعلمها لاعتقاد أنه بهذا يعلم الغيب، أو لأنها هي المحدثة للحوادث، فهذا كله خلاف منهجنا وديننا والواجب على المؤمن أن يتقيد بالأمر الشرعي، وأن يحذر ما نهى الله عنه، والله يقول: قُل لَّا يَعْلَمُ مَن فِي السَّمَاوَاتِ وَالْأَرْضِ الْغَيْبَ إِلَّا اللَّهُ فالغيب عنده وهو الذي يعلمه -جل وعلا- وليس عند المنجمين والسحرة والكهنة، ونحو ذلك ممن يدعون علم الغيب. جزاكم الله خيرًا.

عليكم السلام عسى غياب يومية.xlsm

السلام عليكم و رحمة الله استخدم هذا الكود Sub Get_AbsDay() Dim ws As Worksheet, LR As Long Dim I As Long, C As Range, x As Integer Dim A As String, B As String, Kod As String Dim p As Integer, q As Integer Set ws = Sheets("Sheet1") ws.Range("R8:U8") = "" ws.Range("R10:U10") = "" '--------------------- LR = ws.Range("B" & Rows.Count).End(3).Row Kod = ws.Range("N6").Value p = 17 q = 17 A = "أ" B = "غ" I = 2 Do While I <= LR If ws.Cells(I, 1) = Kod Then ws.Range("N8").Value = ws.Cells(I, 2).Value x = ws.Cells(I, 1).Row For Each C In ws.Range(ws.Cells(x, 3), ws.Cells(x, 10)) If C.Value = A Then p = p + 1 ws.Cells(8, p).Value = ws.Cells(2, C.Column).Value ElseIf C.Value = B Then q = q + 1 ws.Cells(10, q).Value = ws.Cells(2, C.Column).Value End If Next End If I = I + 1 Loop End Sub

السلام عليكم و رحمة الله استخدم الكود التالى 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("Sheet4") t = Timer Application.ScreenUpdating = False '----------------- On Error Resume Next ws.Range("A2:C1000").ClearContents For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) LR = Sh.Range("A" & Rows.Count).End(3).Row Counter = Counter + LR Next '----------------- ReDim Preserve Temp(Counter, 4) y = 0 For Each Sh In Worksheets(Array("Sheet1", "Sheet2", "Sheet3")) For Each C In Sh.Range("A2:A" & LR) If Len(C.Value) > 0 Then Temp(y, 0) = C.Value Temp(y, 1) = C.Offset(0, 1) Temp(y, 2) = C.Offset(0, 2) y = y + 1 End If Next Next '----------------- If y > 0 Then ws.Range("A2").Resize(y, 4).Value = Temp '----------------- Application.ScreenUpdating = True MsgBox Round(Timer - t, 2) End Sub

جرب هذا الكود Private Sub CommandButton1_Click() Dim WB As Workbook Dim SH As Worksheet Dim SH2 As Worksheet Dim SH3 As Worksheet Dim SH4 As Worksheet Dim LR As Long, LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, LR5 As Long, LR6 As Long Dim i As Long, Q As Long, U As Long Dim X As Long, N As Long, T As Long Dim DataArray() As Variant ' مصفوفة لتخزين البيانات مؤقتًا Set WB = ThisWorkbook Set SH = WB.Sheets("CUT") Set SH2 = WB.Sheets("POLISH") Set SH3 = WB.Sheets("AR_ST") Set SH4 = WB.Sheets("AR_PAID") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' تنظيف ورقة SH3 SH3.Range("B4:M" & SH3.Rows.Count).ClearContents ' حساب آخر صفوف البيانات في كل ورقة LR = SH.Cells(SH.Rows.Count, "D").End(xlUp).Row LR1 = SH3.Cells(SH3.Rows.Count, "B").End(xlUp).Row + 1 LR2 = SH2.Cells(SH2.Rows.Count, "E").End(xlUp).Row LR5 = SH4.Cells(SH4.Rows.Count, "B").End(xlUp).Row ' تخزين البيانات في مصفوفة ReDim DataArray(1 To LR - 3, 1 To 6) X = 1 For i = 4 To LR If SH3.Cells(2, "B") = SH.Cells(i, "D") And SH.Cells(i, "AC") <> "0" Then DataArray(X, 1) = SH.Cells(i, "O") DataArray(X, 2) = SH.Cells(i, "F") DataArray(X, 3) = SH.Cells(i, "G") DataArray(X, 4) = SH.Cells(i, "P") DataArray(X, 5) = SH.Cells(i, "AC") X = X + 1 End If Next i ' كتابة البيانات في ورقة SH3 SH3.Range("B" & LR1).Resize(X - 1, 5).Value = DataArray N = LR1 + X - 1 ' تخزين البيانات من SH2 في مصفوفة ReDim DataArray(1 To LR2 - 3, 1 To 6) X = 1 For Q = 4 To LR2 If SH3.Cells(2, "B") = SH2.Cells(Q, "E") Then DataArray(X, 1) = SH2.Cells(Q, "B") DataArray(X, 2) = SH2.Cells(Q, "C") DataArray(X, 3) = SH2.Cells(Q, "D") DataArray(X, 4) = SH2.Cells(Q, "G") DataArray(X, 5) = SH2.Cells(Q, "L") DataArray(X, 6) = SH2.Cells(Q, "P") X = X + 1 End If Next Q ' كتابة البيانات في ورقة SH3 SH3.Range("B" & N).Resize(X - 1, 6).Value = DataArray T = N + X - 1 ' تخزين البيانات من SH4 في مصفوفة ReDim DataArray(1 To LR5 - 3, 1 To 2) X = 1 For U = 4 To LR5 If SH3.Cells(2, "B") = SH4.Cells(U, "C") Then DataArray(X, 1) = SH4.Cells(U, "B") DataArray(X, 2) = SH4.Cells(U, "F") X = X + 1 End If Next U ' كتابة البيانات في ورقة SH3 SH3.Range("B" & T).Resize(X - 1, 2).Value = DataArray Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

عندما تريد المساعدة وجب ارفاق الملف ووضع البيانات قبل وكيف تكون بعد ، وما هو حجم بياناتك حتى يكون الكود بطيء ؟!! بنظرة على كودك يوجد حلقات تكرارية كثيرة وهذا الذي سيسبب البطيء . اختصر الحلقات التكرارية قدر الإمكان . تحياتي .

انت غيرت المسميات عن المثال الاول حتى حقول البحث انت غيرت اسماءها ، وهو سبب عدم ظهور النتائج تم التعديل وآمل منك اخي الكريم انك تخصص مستقبلا لكل استفسار موضوع وعنوان جديد يخصه New3.rar

وعليكم السلام ورحمة الله وبركاتة اخي مصطفى العراقي1988 يمكنك استخدام اله البحث بالمنتدي جرب هذا امر تسليمCBS ان لم يكن طلبك ..... يرجي رفع ملف لتسهيل فهم المطلوب

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

ضع هذا الكود في زر الخروج أو تبديل المستخدم ( حدث عند النقر ) ، حسب رغبتك وحاجتك DoCmd.Close acForm, Me.Name DoCmd.OpenForm "Login", acNormal Me.Name = الفورم الرئيسي الحالي Login = فورم الدخول

جزاكم الله خيرا اشتغلت فعلا وعملت عليها تعديل بسيط علشان اما الخلية تكون فارغة ميعملش رسالة خطأ هكتبها علشان لو حد حابب يستفيد منها فى خلية سعر الوحدة =IF(ISERROR(VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0);0));0;VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0);0)) فى خلية سعر النقل =IF(AND(L6>0;OR(S6="ض نقل";S6="نقل"));VLOOKUP(C6;$T$5:$AI$100;MATCH(B6;$T$5:$AI$5;0)+1;0);0)

بارك الله بيك تعبك وجهدك مشكور عليه 🌹🌹🌹

استاذنا الفاضل ومعلمنا @أ / محمد صالح حل اكثر من رائع وغاية السهولة واليسر تقبل تحياتى

بعد إذن أخي الغالي @احمد عبدالحليم يمكنك استعمال هذا الاجراء لوضع أسماء الشيتات ايا كان عددها في العمود B Sub sheetsnames() n = 4 For Each sh In ThisWorkbook.Sheets If sh.Name <> "الرئيسية" Then Range("b" & n) = sh.Name n = n + 1 End If Next sh MsgBox "ok" End Sub واستعمال هذا الكود في حدث تغيير قيمة الخلايا في شيت الرئيسية Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$2" Then Range("C4:C12").Formula = "=VLOOKUP($B$2,INDIRECT(""'""&B4&""'!a2:b10000""),2,0)" Range("C4:C12").Value = Range("C4:C12").Value End If End Sub بالتوفيق

بدلا من الكود الخاص بنسخ 32بت فقط ويكون السطر مكتوب باللون الأحمر تضع هذا السطر بعد elde وتضع نفس السطر بعد غضافة ptrsafe قبل function بعد if vba7

وعليكم السلام ورحمة الله وبركاته تفضل اخى @husain alhammadi ملحوظة مهمة جدا يجب ان يكون اسماء الشيتات هى نفسها فى شيت الرئيسية (وذا كان هناك اسم شيت غير متطابق مع نفس اسم الشيت فى الشيت الرئسيى سوف تظهر رسالة تخبرك بهذا الشيت غير متطابق واتمنى بعد وضع الكلمات وترجمتها لهذه اللغات ان ترفع الملف لنا مرة اخرى فكرة رائعة بل اكثر من رائعة تقبل تحياتى ترجمة.2xlsm.xlsm

عليكم السلام myTxtSahm=fnAreaSahm([حقل المجموع الكلي(اسهم)]) myTxtQerat=fnAreaQerat([حقل المجموع الكلي(اسهم)]) myTxtFdan=fnAreaFdan([حقل المجموع الكلي(اسهم)]) اتمنى ان هذا واضح باعتبار myTxtSahm هو حقل الاسهم في التقرير و myTxtQerat هو حقل القراريط التقرير و myTxtFdan هو حقل الأفدنة في التقرير

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

شكرا اخى الفاضل على كلماتك الطيبة تقبل تحياتى

مشاركة مع اخي @محمد احمد لطفى تفضل ..... Output_Path = "C:\Users\ACER\Desktop" & "\" & Format(Date, "dd-mm-yyyy") & ".xlsx" DoCmd.OutputTo acOutputQuery, "استعلام1", "ExcelWorkbook(*.xlsx)", Output_Path, True, "", , acExportQualityPrint

عملت لك زر لتفريغ الحقول وتحديث النموذج Bank2.rar

تفضل اخى مطلبك على الملف الذى ارفقته سابقا بعد توضيح المطلوب DataBASE2.xlsm ولكن اذا كان غياب الموظف اكثر 7 ايام سوف يحدث خطأ بسبب التنسيقات حيث ان الجداول اسفل بعضها فى شيت Abs لذلك اليك حل اخر بحيث تكون الجداول لانواع الاجازات بجوار بعضها البحث برقم الموظف .xlsm فى كلا الملفين اكتب رقم الموظف سوف تحصل على الاجازات تقبل تحياتى

السلام عليكم بها نبدأ أى مشاركة -بما انك لم تقم برفع ملف -فيمكنك استخدام هذا الكود لطلبك: Sub ColorCompanyDuplicates() Dim xRg As Range Dim xTxt As String Dim xCell As Range Dim xChar As String Dim xCellPre As Range Dim xCIndex As Long Dim xCol As Collection Dim i As Long On Error Resume Next If ActiveWindow.RangeSelection.Count > 1 Then xTxt = ActiveWindow.RangeSelection.AddressLocal Else xTxt = ActiveSheet.UsedRange.AddressLocal End If Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8) If xRg Is Nothing Then Exit Sub xCIndex = 2 Set xCol = New Collection For Each xCell In xRg On Error Resume Next If xCell.Value <> "" Then xCol.Add xCell, xCell.Text If Err.Number = 457 Then xCIndex = xCIndex + 1 Set xCellPre = xCol(xCell.Text) If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex ElseIf Err.Number = 9 Then MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel" Exit Sub End If On Error GoTo 0 End If Next End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim A As Range, B As Range, j As Range, lr As Long lr = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row Application.ScreenUpdating = False Set A = Range("R2:R" & lr) Set B = Range("D2:F" & lr) For Each j In Union(A, B) With j 'Modify it to suit you '.NumberFormat = "mm/dd/yyyy" .NumberFormat = "yyyy/dd/mm" End With Next j Application.ScreenUpdating = True End Sub

وتم إضافة بعض اللمسات الصغيرة 😅 هذه المشاركة

السلام عليكم أخي الكريم جرب الكود التالي في حدث المصنف ThisWorkbook Private Sub Workbook_NewSheet(ByVal Sh As Object) Dim R As Integer, G As Integer, B As Integer Randomize R = Int(Rnd() * 256) G = Int(Rnd() * 256) B = Int(Rnd() * 256) Sh.Tab.Color = RGB(R, G, B) End Sub سيعمل الكود فقط عند إضافة ورقة عمل جديدة

لا مشكلة في حدث قبل التحديث للكمبو0 نضع الامر If Application.CurrentProject.AllReports("sos").IsLoaded = True Then DoCmd.Close ObjectType:=acReport, ObjectName:="sos", Save:=acSavePrompt Else End If الملف مرفق اخونا الشايب Database110(1).accdb

السلام عليكم ورحمة الله وبركاته بالنسبة لي انا استخدم طريقة ثانية وهي اقوم بوضع اوامر sql في جدول واضيف عمود id مع عمود sql ثم استدعي الكود باستخدام الدالة dlookup ثم استدعيها بالكود التالي DoCmd.RunSQL DLookup("[sql]", "sql", "[id]=1")

السلام عليكم ورحمة الله وبركاته في المثال غنية عن المقال فتح الصورة بالمستعرض.rar