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

السلام عليكم نبدأ بها 

جرب الكود التالي

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