ياسر خليل أبو البراء

السلام عليكم نبدأ بها جرب الكود التالي Sub Test() Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("اذن") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub Select Case ws.Range("C2").Value Case "اذن صرف": sTarget = "صرف" Case "اذن اضافه": sTarget = "اضافه" Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub End Select Set sh = ThisWorkbook.Worksheets(sTarget) m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1 For iRow = 6 To lr sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value) sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value If sh.Name = "اضافه" Then sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value End If m = m + 1 Next iRow Application.ScreenUpdating = True MsgBox "Done", 64 End Sub

ما المشكلة في استخدام الدالة Trunc .. إن الدالة تعطيك الرقم الصحيح ولا يوجد أية كسور الرجاء توضيح المشكلة بمزيد من الأمثلة والمنطق المتبع في الحل.

وعليكم السلام =TRUNC(E1*F1/G1,0)

أخي العزيز محمد هشام أهناك شيء مختلف في الكود الموضوع في الملف المرفق الخاص بكم؟

الكود يعمل على كل الصفحات بالمصنف

وعليكم السلام Sub Test() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Rows("1:2").RowHeight = 30 ws.Rows("3:" & Rows.Count).RowHeight = 20 Next ws End Sub

ولتجنب استخدام جملة On Error Resume Next يمكن تعديل الكود بهذا الشكل Sub Test2() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets With ws If .AutoFilterMode Then .AutoFilterMode = False If .FilterMode = True Then .ShowAllData End If End With Next ws Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته جرب الكود التالي عله يفي بالغرض Sub Test() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets If ws.AutoFilterMode Then On Error Resume Next ws.ShowAllData On Error GoTo 0 End If Next ws Application.ScreenUpdating = True End Sub

ارفق المثال الذي تعمل عليه بالضبط أو حاول بنفسك تغيير النطاق فقط في المعادلة المستخدمة في ورقة العمل

وعليكم السلام أخي الكريم أدرج موديول جديد وضع الدالة المعرفة التالية في الموديول Function xDupsV(fCol As Range, Optional offsetCol As Integer = -1) Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, i As Long, j As Long Application.Volatile True Set r1 = fCol Set r2 = r1.Offset(, offsetCol) ReDim a(1 To 1) For Each c In r1 Set cc = c.Offset(, offsetCol) If Not IsEmpty(c) And cc > 0 Then For j = 1 To cc i = i + 1 ReDim Preserve a(1 To i) a(i) = c Next j End If Next c xDupsV = WorksheetFunction.Transpose(a) End Function ثم في الخلية C11 ضع المعادلة بهذا الشكل =xdupsv(F3:F6) لا تنسى أن تقوم بمسح النطاق C11 إلى آخر النطاق قبل وضع المعادلة

وعليكم السلام جرب الكود التالي Private Sub UserForm_Initialize() Dim fso As Object, oFolder As Object, sPath As String, i As Long sPath = "D:\" Set fso = CreateObject("Scripting.FileSystemObject") UserForm1.ListBox1.Clear If fso.FolderExists(sPath) Then Set oFolder = fso.GetFolder(sPath) For Each oFolder In oFolder.SubFolders If Left(oFolder.Name, 1) <> "$" Then i = i + 1 UserForm1.ListBox1.AddItem oFolder.Name End If Next oFolder End If Set fso = Nothing End Sub

غير الجزء التالي If Weekday(Cells(4, i)) > 5 ليصبح If Weekday(Cells(4, i)) = 6

بارك الله فيكم إخواني الكرام ومشكور على مروركم العطر وجزيتم خيراً على دعواتكم المباركة لوالدي رحمة الله عليه

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم الملف التالي وهو ببساطة ملف يتم فيه تسجيل الغياب اليومي بشكل سهل ومرن ، ومن خلاله يمكنك الحصول على تقارير لأيام الغياب لأي أسبوع وهو مفيد لشئون الطلبة ومسئولي الحكومة الإلكترونية في التعامل مع خدمة تسجيل الغياب الأسبوعي. وسأترك الشرح بالتفصيل للأخ العزيز / عماد غازي ، وإليكم رابط الفيديو الخطوة الأولي: فك الضغط عن الملف المضغوط ستجد ملف باسم Dummy.xlsx هذا الملف يتم وضع بيانات المدرسة فيه (كود الطالب - اسم الطالب - الصف - الفصل) والملف الثاني ملف برنامج السجل الالكتروني قم بفتحه ونفذ الأمر GETDATA مرة واحدة فقط عند أول استخدام للبرنامج ، بحيث يتم إضافة بيانات الطلاب في البرنامج ، والأمر موجود في شريط الوصول السريع على شكل جرس. أكرر هذا الأمر يقوم بمسح البيانات في البرنامج من قاعدة البيانات DB بالكامل ، لذا وجب التنبيه أن هذا الأمر يتم تنفيذه مرة واحدة فقط عند استخدام البرنامج لأول مرة. تم إضافة ورقة عمل باسم HP فيها تعليمات كيفية التعامل مع البرنامج ، يرجى قراءة التعليمات جيداً قبل التعامل مع البرنامج ** في انتظار إضافاتكم ومقترحاتكم واستفساراتكم حول كيفية استخدام البرنامج أو الإبلاغ عن أي خطأ لكي يتم معالجته إن شاء الله تم تحديث الملف المرفق بتاريخ 6 أكتوبر 2023 الساعة 06:00 مساءاً أسألكم الدعاء لوالدي الذي رحل عن الدنيا ، أسأل الله له المغفرة والرحمة والفردوس الأعلى من الجنة ، وسأعتبر هذا البرنامج صدقة جارية على روح والدي. أخوكم في الله / ياسر خليل أبو البراء رابط الموضوع الأصلي من هنا https://techno7asry.com/forum/t6265

راجع الرابط جيداً أخي

تفضل الرابط (أزل المسافات ) https: // techno7asry . com /forum/ t1865 ما هو إصدار الكروم لديك؟ جرب الرابط التالي عله يفيدك https://googlechromelabs.github.io/chrome-for-testing/

وعليكم السلام يمكن استخدام أداة السلينوم والتي يمكن تسطيبها في الإكسيل والتعامل معها برمجياً من خلال VBA .. ويوجد موضوعات قدمتها في أكاديمية الصقر بخصوص هذه الأداة ولكن المنتدى هنا يمنع فيه وضع الروابط الخارجية.

حاول تتبع الكود سطر بسطر وأشر لي على السطر الذي يحتاج لشرح وتوضيح لأني لا أملك الوقت الكافي للشرح. أو انتظر أحد الأخوة يقدم لك شرح ولو مبسط عموماً السطر الذي يهمك أعتق هذا السطر dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) حيث يتم تخزين القيم المطلوب التعامل معها في مصفوفة أحادية الأبعاد .. للخلايا التي تلي خلية الاسم في الأعمدة التالية لها مباشرة حيث تم استخدام الدالة Offset وهي دالة الإزاحة وتختلف الإزاحة في كل مرة حسب مكان العمود ..

وعليكم السلام أخي الكريم قم بتغيير اسم الملف المسمى بيانات العاملين 21-9-2023 إلى Employees DB أو قم بتغيير الاسم في الكود (كما يحلو لك) ضع الكود التالي في الملف المسمى الإدارة العامة Sub Test() Dim a, wb As Workbook, ws As Worksheet, sh As Worksheet, c As Range, dic As Object, sName As String, lr As Long Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Set wb = Workbooks.Open(ThisWorkbook.Path & "\Employees DB.xls") Set ws = wb.Worksheets(1) Set sh = ThisWorkbook.ActiveSheet For Each c In ws.Range("C6:C" & ws.Cells(Rows.Count, "C").End(xlUp).Row) sName = c.Value If Not dic.Exists(sName) And sName <> Empty Then dic.Add sName, Array(c.Offset(0, 1).Value, c.Offset(0, 2).Value, c.Offset(0, 3).Value) End If Next c wb.Close SaveChanges:=False lr = sh.Cells(Rows.Count, "B").End(xlUp).Row sh.Range("E3:G" & lr).ClearContents For Each c In sh.Range("B3:B" & lr) sName = c.Value If dic.Exists(sName) Then a = dic(sName) c.Offset(, 3).Resize(, 3).Value = a End If Next c Application.ScreenUpdating = True End Sub

السلام عليكم جرب الكود التالي Sub Test() Dim sRow As Long, eRow As Long sRow = 8: eRow = 19 With ActiveSheet .Range("D" & sRow & ":D" & eRow).Value = .Range("F" & sRow & ":F" & eRow).Value .Range("E" & sRow & ":E" & eRow).Value = 0 End With End Sub

جرب الكود التالي عله يفي بالغرض بإذن الله Sub Test() Dim x, ws As Worksheet, lr As Long, i As Long, j As Long, startSeq As Long, endSeq As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) lr = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row ws.Range("A2:A" & lr).ClearContents For i = 2 To lr j = 0 x = Application.Match(ws.Cells(i, "L").Value, ws.Columns("T"), 0) If Not IsError(x) Then startSeq = ws.Cells(x, "U").Value endSeq = ws.Cells(x, "V").Value Do j = j + 1 ws.Cells(i + j - 1, "A").Value = startSeq If startSeq > endSeq Then ws.Cells(i + j - 1, "A").Value = Empty startSeq = startSeq + 1 Loop Until ws.Cells(i, "L").Value <> ws.Cells(i + j, "L").Value i = i + j - 1 End If Next i Application.ScreenUpdating = True End Sub إذا قمت بحذف صفوف من البيانات سيلزمك تنفيذ الكود من جديد لضبط التسلسل

وعليكم السلام هل البيانات في العمود L ثابتة أم أنك تريد الترقيم والبيانات في العمود L معاً كنتائج؟ وماذا لو كان العمود L ثابت وحذفت 10 صفوف على سبيل المثال؟

وعليكم السلام في الخلية A2 جرب المعادلة التاليه =SUBTOTAL(103, $L$2:L2)

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

وعليكم السلام أخي الكريم ياسر جرب الكود التالي عله يفي بالغرض بإذن الله تم الاعتماد على العمود R في الورقة الثانية لتسجيل اسم Check Box الذي تم ترحيله تفادياً لترحيله مرة أخرى .. يمكنك إخفاء العمود أو إخفاء القيم في العمود R Sub Test() Dim x, ws As Worksheet, sh As Worksheet, chkBox As CheckBox, r As Long, m As Long, cnt As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) Set sh = ThisWorkbook.Sheets(2) For r = 3 To ws.Cells(ws.Rows.Count, "C").End(xlUp).Row Set chkBox = ws.Shapes("Check Box " & r - 2).OLEFormat.Object x = Application.Match(chkBox.Name, sh.Columns("R"), 0) If IsError(x) Then If chkBox.Value = 1 Then m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 sh.Range("A" & m).Resize(, 17).Value = ws.Range("A" & r).Resize(, 17).Value sh.Range("R" & m).Value = chkBox.Name cnt = cnt + 1 End If End If Next r Application.ScreenUpdating = True If cnt > 0 Then MsgBox "Total = " & cnt, 64 Else MsgBox "Nothing Transferred", vbExclamation End Sub