Mohammed Alsakka قام بنشر أكتوبر 3 مشاركة قام بنشر أكتوبر 3 السلام عليكم في ورقة العمل تم استخراج البيانات باستخدام دالة فلتر في فيجوال بيسك ولكن المشكلة في الترقيم كيف اعيد الترقيم باستخدام فيجوال بيسك مع دالة فلتر بحيث ابدا من 1 الى اخره box.xlsm رابط هذا التعليق شارك More sharing options...
AmirMohamed قام بنشر أكتوبر 5 مشاركة قام بنشر أكتوبر 5 (معدل) تفضل اخي الحبيب وهذه المعادلة المستخدمة : =IF(B3<>""; SUBTOTAL(3; $B$2:B3); "") اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له box (1).xlsm تم تعديل أكتوبر 5 بواسطه AmirMohamed 1 رابط هذا التعليق شارك More sharing options...
Mohammed Alsakka قام بنشر أكتوبر 6 الكاتب مشاركة قام بنشر أكتوبر 6 اخي اتوقع لما توضح لك الفكرة عند الضعط على زر الماكرو يظهر فورم الفلتر يقوم بعمل ولكن الارقام التسلسل لما تبدا من 1 الى اخرة هل اذا ضفت الكود يرتب من الواحد 15 ساعات مضت, AmirMohamed said: تفضل اخي الحبيب وهذه المعادلة المستخدمة : =IF(B3<>""; SUBTOTAL(3; $B$2:B3); "") اما عن فيجوال فيجوال بيسك نحتاج السورس كود للمشروع لكي يتم عمل الكود اللازم له box (1).xlsm 13.84 kB · 4 downloads الدرس 259 (1).xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة AmirMohamed قام بنشر أكتوبر 6 أفضل إجابة مشاركة قام بنشر أكتوبر 6 تمام وضحت الفكرة ، اليك المرفق بكود جديد وبه بعض التنسيقات ان شاء الله تعجبك 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 رابط هذا التعليق شارك More sharing options...
Mohammed Alsakka قام بنشر الأربعاء at 05:04 الكاتب مشاركة قام بنشر الأربعاء at 05:04 التعديل الحديث لم يعمل المطلوب من الفيجوال بيسك وهو فلتر بين تاريخ واظهار النتائج في الشيت المطلوب في 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 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان