استفسار عن طريقة ترقيم

[Mohammed Alsakka]

السلام عليكم

في ورقة العمل تم استخراج البيانات باستخدام دالة فلتر في فيجوال بيسك ولكن المشكلة في الترقيم كيف اعيد الترقيم باستخدام فيجوال بيسك مع دالة فلتر بحيث ابدا من 1 الى اخره

box.xlsm

[AmirMohamed]

تفضل اخي الحبيب

وهذه المعادلة المستخدمة :

=IF(B3<>""; SUBTOTAL(3; $B$2:B3); "")

اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له 

box (1).xlsm

تم تعديل أكتوبر 5, 2024 بواسطه AmirMohamed

[Mohammed Alsakka]

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

15 ساعات مضت, AmirMohamed said:

تفضل اخي الحبيب

وهذه المعادلة المستخدمة :

=IF(B3<>""; SUBTOTAL(3; $B$2:B3); "")

اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له 

box (1).xlsm 13.84 kB · 4 downloads

الدرس 259 (1).xlsm

[AmirMohamed]

تمام وضحت الفكرة ، اليك المرفق بكود جديد وبه بعض التنسيقات ان شاء الله تعجبك

Private Sub CommandButton1_Click()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim destRow As Long
    Dim dateFrom As Date
    Dim dateTo As Date
    Dim i As Long
    Dim headerRange As Range
    Dim tableRange As Range
    
    Set wsSource = ThisWorkbook.Sheets("ورقة1")
    Set wsDest = ThisWorkbook.Sheets("ورقة2")
    
    dateFrom = CDate(TextBox1.Value)
    dateTo = CDate(TextBox2.Value)
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "F").End(xlUp).Row
    destRow = 1

    wsSource.Range(wsSource.Cells(1, 2), wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft)).Copy _
        Destination:=wsDest.Cells(destRow, 2)
    wsDest.Cells(destRow, 1).Value = "م"
    wsDest.Cells(destRow, 1).Font.Bold = True
    wsDest.Cells(destRow, 1).Font.Size = 18
    wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Bold = True
    wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 18
    destRow = destRow + 1
    
    For i = 2 To lastRow
        If wsSource.Cells(i, 6).Value >= dateFrom And wsSource.Cells(i, 6).Value <= dateTo Then
            
            wsSource.Range(wsSource.Cells(i, 2), wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft)).Copy _
                Destination:=wsDest.Cells(destRow, 2)
            wsDest.Cells(destRow, 1).Value = destRow - 1
            wsDest.Cells(destRow, 1).Font.Size = 16
            wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 16
            destRow = destRow + 1
        End If
    Next i

    
    Set headerRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(1, 7))
    headerRange.Interior.Color = RGB(0, 102, 204)
    headerRange.Font.Color = RGB(255, 255, 255)

    
    wsDest.Columns("A").AutoFit
    wsDest.Columns("B").Resize(, wsSource.Columns.Count - 1).AutoFit

    
    Set tableRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(destRow - 1, 7))
    With tableRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Color = RGB(173, 216, 230)
    End With

    MsgBox "تم فلترة البيانات بنجاح!"
End Sub

وفي كود الحذف بتضيف سطر كمان 

Private Sub CommandButton2_Click()
On Error Resume Next
sh2.Range("a1").CurrentRegion.Delete
sh2.Range("a1").CurrentRegion.Clear
End Sub

اليك المرفق به التعديلات ♥

الدرس 259 (1).xlsm

[Mohammed Alsakka]

التعديل الحديث لم يعمل المطلوب من الفيجوال بيسك وهو فلتر بين تاريخ واظهار النتائج في الشيت المطلوب

في 6‏/10‏/2024 at 16:52, AmirMohamed said:

تمام وضحت الفكرة ، اليك المرفق بكود جديد وبه بعض التنسيقات ان شاء الله تعجبك

Private Sub CommandButton1_Click()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    Dim destRow As Long
    Dim dateFrom As Date
    Dim dateTo As Date
    Dim i As Long
    Dim headerRange As Range
    Dim tableRange As Range
    
    Set wsSource = ThisWorkbook.Sheets("ورقة1")
    Set wsDest = ThisWorkbook.Sheets("ورقة2")
    
    dateFrom = CDate(TextBox1.Value)
    dateTo = CDate(TextBox2.Value)
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "F").End(xlUp).Row
    destRow = 1

    wsSource.Range(wsSource.Cells(1, 2), wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft)).Copy _
        Destination:=wsDest.Cells(destRow, 2)
    wsDest.Cells(destRow, 1).Value = "م"
    wsDest.Cells(destRow, 1).Font.Bold = True
    wsDest.Cells(destRow, 1).Font.Size = 18
    wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Bold = True
    wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 18
    destRow = destRow + 1
    
    For i = 2 To lastRow
        If wsSource.Cells(i, 6).Value >= dateFrom And wsSource.Cells(i, 6).Value <= dateTo Then
            
            wsSource.Range(wsSource.Cells(i, 2), wsSource.Cells(i, wsSource.Columns.Count).End(xlToLeft)).Copy _
                Destination:=wsDest.Cells(destRow, 2)
            wsDest.Cells(destRow, 1).Value = destRow - 1
            wsDest.Cells(destRow, 1).Font.Size = 16
            wsDest.Cells(destRow, 2).Resize(1, wsSource.Columns.Count - 1).Font.Size = 16
            destRow = destRow + 1
        End If
    Next i

    
    Set headerRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(1, 7))
    headerRange.Interior.Color = RGB(0, 102, 204)
    headerRange.Font.Color = RGB(255, 255, 255)

    
    wsDest.Columns("A").AutoFit
    wsDest.Columns("B").Resize(, wsSource.Columns.Count - 1).AutoFit

    
    Set tableRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(destRow - 1, 7))
    With tableRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .Color = RGB(173, 216, 230)
    End With

    MsgBox "تم فلترة البيانات بنجاح!"
End Sub

وفي كود الحذف بتضيف سطر كمان 

Private Sub CommandButton2_Click()
On Error Resume Next
sh2.Range("a1").CurrentRegion.Delete
sh2.Range("a1").CurrentRegion.Clear
End Sub

اليك المرفق به التعديلات ♥

الدرس 259 (1).xlsm 29.97 kB · 12 downloads