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

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim rng As Range
Dim cell As Range
Set rng = Range("b7:b99")
For Each cell In rng
If cell.Value = 0 Or cell.Value = "" Then
cell.EntireRow.Hidden = True
End If
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

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


أريد أن أطبع الأسطر التي فيها قيمة العود الموجود في الصورة السابقة(NT) أكبر من 0 أو أكبر من الفراغ. طبعا هنا نستطيع إستعمال كود إخفاء الصفوف الذي ذكرناه أولا لكن كما قلنا سابقا سوف نواجه مشاكل في بعض الحواسب وليس كلها.
الحل هو
أولا نضيف ورقة ثانية في الملف كماهي موضحة في الصورة

ثم نقوم بإدراج يوزر فورم فيه ليست بوكس و زر للطباعة كما هو موضح في الشكل التالي

نضغ على اليوزر فورم دبل كليك ونضع الكود التالي

Private Sub UserForm_Activate()
 'هذا الجزأ خاص بمسح البيانات الموجودة في الورقة data2
'وكذلك لتقسيم الليس بوكس
Sheets("data2").Activate

Range("A7:K99").Select
    Selection.ClearContents
    Sheets("data").Activate

ListBox1.ColumnWidths = "68;68;68;68;68;68;68;68;68;68"         'Column Widths Of Listbox
ListBox1.ColumnCount = 10
ListBox1.Clear
'==================================
'هذا  الجزأ خاص بتعبأة الليست بوكس بالبيانات المطلوبة
Dim i As Long
lastrow = Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Row
For i = 7 To 99
If Cells(i, 2).Value <> 0 Then
    Cells(i, 1).Select
Range(ActiveCell, ActiveCell.Offset(0, 10)).Select
 With UserForm2.ListBox1
            .AddItem
            .List(.ListCount - 1, 0) = ActiveSheet.Cells(i, 1).Text
            .List(.ListCount - 1, 1) = ActiveSheet.Cells(i, 2).Value
            .List(.ListCount - 1, 2) = ActiveSheet.Cells(i, 3).Value
            .List(.ListCount - 1, 3) = ActiveSheet.Cells(i, 4).Value
            .List(.ListCount - 1, 4) = ActiveSheet.Cells(i, 5).Value
            .List(.ListCount - 1, 5) = ActiveSheet.Cells(i, 6).Value
            .List(.ListCount - 1, 6) = ActiveSheet.Cells(i, 7).Value
            .List(.ListCount - 1, 7) = ActiveSheet.Cells(i, 8).Value
            .List(.ListCount - 1, 8) = ActiveSheet.Cells(i, 9).Value
            .List(.ListCount - 1, 9) = ActiveSheet.Cells(i, 10).Value
                    
        End With
        
      End If
      Next
 Application.CutCopyMode = False
End Sub

وهذا الكود هو لمسح البيانات من الورقة 2 وتعبيئة الليست بوكس بالبيانات التي تحقق الشرط المعلن عنه في الكود من الورقة 1
ثم نضغط دبل كلك على زر الطباعة وندر الكود التالي

 'هذا الجزأ خاص بتحديد كل البيانات الموجودة داخل الليست بوكس
 Dim r As Long
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ListBox1.ListIndex = -1

ListBox1.MultiSelect = fmMultiSelectMulti
    For r = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(r) = True
    Next r
   
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
 '---------------------------------------------------------------------------
 ' أما هذا الجزء فهو لنسخ البيانات الموجودة داخل اليست بوكس على الورقة الثانية
 Dim Litem As Long, LbRows As Long, LbCols As Long
 Dim bu As Boolean
 Dim Lbloop As Long, Lbcopy As Long
 
 LbRows = ListBox1.ListCount - 1
 LbCols = ListBox1.ColumnCount - 1
   
    For Litem = 0 To LbRows
    If ListBox1.Selected(Litem) = True Then
          bu = True
          Exit For
    End If
    Next
    If bu = True Then
    With Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
      
            For Litem = 0 To LbRows
                If ListBox1.Selected(Litem) = True Then 'Row selected
                  ''Increment variable for row transfer range
                  Lbcopy = Lbcopy + 1
            For Lbloop = 0 To LbCols
                  ''Transfer selected row to relevant row of transfer range
            .Cells(Lbcopy, Lbloop + 1) = ListBox1.List(Litem, Lbloop)
                       
           Next Lbloop
                End If
            Next
            For m = 0 To LbCols
                With Sheets("DATA2").Cells(Rows.Count, 1).End(xlUp).Offset(0, m).Borders(xlEdgeBottom)
                End With
Next
        End With
    Else
         MsgBox "Rinen n'a choisi", vbCritical
         Exit Sub
    End If
     Sheets("data2").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

ActiveSheet.Range("a1:k102").PrintOut
End Sub

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