[حل شده] حذف مقادیر از پیش تعین شده

[mehdi.chatrbahr]

سلام
من یه فایل گزارش خیلی حجیم دارم که بخش های خیلی زیادی از محتوای این فایل رو بهش هیچ احتیاجی ندارم و عملاً باعث کاهش سرعت میشه، میخوام بصورت اتوماتیک قبل از اینکه نیاز به باز شدن اکسل باشه یه برنامه بنویسم شرط ها رو بهش بدم و بعد از اینکه برنامه رو اجرا کردم تمامی اطلاعات اضافی از داخل فایل حذف بشه و یه خروجی جدید بهم بده.
استفاده از توابع خود اکسل بخاطر حجم 48 مگابایتی فایل اصلی، مشکلم رو حل نمیکنه.
اگر مقدایری که میخوام حذف بشه رو بعنوان موضوعات فیلتر در نظر بگیریم، علاوه بر اینکه اینکه مقادیر خود شرط باید حذف بشه لازمه که کل دیتاهای وابسته بهش هم در همون ردیف حذف بشه
ممنون میشم راهنمایی بفرمائید.

[M_ExceL]

سلام
من یه فایل گزارش خیلی حجیم دارم که بخش های خیلی زیادی از محتوای این فایل رو بهش هیچ احتیاجی ندارم و عملاً باعث کاهش سرعت میشه، میخوام بصورت اتوماتیک قبل از اینکه نیاز به باز شدن اکسل باشه یه برنامه بنویسم شرط ها رو بهش بدم و بعد از اینکه برنامه رو اجرا کردم تمامی اطلاعات اضافی از داخل فایل حذف بشه و یه خروجی جدید بهم بده.
استفاده از توابع خود اکسل بخاطر حجم 48 مگابایتی فایل اصلی، مشکلم رو حل نمیکنه.
اگر مقدایری که میخوام حذف بشه رو بعنوان موضوعات فیلتر در نظر بگیریم، علاوه بر اینکه اینکه مقادیر خود شرط باید حذف بشه لازمه که کل دیتاهای وابسته بهش هم در همون ردیف حذف بشه
ممنون میشم راهنمایی بفرمائید.

سلام،
بعد از اجرای فایل، ابتدا ماکرو را فعال کنید سپس روی باتن 1 کلیک کنید.
توضیح :
قبل از هر کاری از فایل اصلیتون کپی تهیه کنید.
شروط شما به شیت 2 منتقل شده است.
فایل نهایی با نام "new file" و در مسیر فایل اصلی ذخیره می گردد.

Sub M_E()

Dim bdata As Boolean

Dim i, lr, lr2, h, chk As Long

Dim fDir As String

With Application

lr = Cells(Rows.Count, 1).End(3).Row

    .ScreenUpdating = False
    
        For i = 2 To lr
        
        h = 2
        
            Do While h < 8
            
                If Cells(i, 10) = Sheets(2).Cells(h, 2) Then
                    Range("a" & i).EntireRow.Delete
                    i = i - 1
                End If
                h = h + 1
                
            Loop
        
        Next
    
        lr2 = Cells(Rows.Count, 1).End(3).Row
        
        For i = 2 To lr2
        
            h = 2
            bdata = True
            
                Do While h < 16
                
                    If Cells(i, 6) <> Sheets(2).Cells(h, 1) And Cells(i, 6) <> Empty Then
                    
                       For chk = 2 To 16
                       
                           If Cells(i, 6) = Sheets(2).Cells(chk, 1) Then
                           
                               bdata = False
                               Exit For
                               
                           End If
                           
                       Next chk
                       
                       If bdata = True Then
                       
                           Range("a" & i).EntireRow.Delete
                           i = i - 1
                           
                       End If
                       
                    End If
                    
                    h = h + 1
                
                Loop
        
        Next
    
    .ScreenUpdating = True
    .DisplayAlerts = False
    
        fDir = ThisWorkbook.Path & "\new file.xlsx"
        ActiveWorkbook.SaveAs Filename:=fDir, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
            
    .DisplayAlerts = True
    
End With

End Sub

یا حق.

[mehdi.chatrbahr]

سلام،
بعد از اجرای فایل، ابتدا ماکرو را فعال کنید سپس روی باتن 1 کلیک کنید.
توضیح :
قبل از هر کاری از فایل اصلیتون کپی تهیه کنید.
شروط شما به شیت 2 منتقل شده است.
فایل نهایی با نام "new file" و در مسیر فایل اصلی ذخیره می گردد.

Sub M_E()

Dim bdata As Boolean

Dim i, lr, lr2, h, chk As Long

Dim fDir As String

With Application

lr = Cells(Rows.Count, 1).End(3).Row

    .ScreenUpdating = False
    
        For i = 2 To lr
        
        h = 2
        
            Do While h < 8
            
                If Cells(i, 10) = Sheets(2).Cells(h, 2) Then
                    Range("a" & i).EntireRow.Delete
                    i = i - 1
                End If
                h = h + 1
                
            Loop
        
        Next
    
        lr2 = Cells(Rows.Count, 1).End(3).Row
        
        For i = 2 To lr2
        
            h = 2
            bdata = True
            
                Do While h < 16
                
                    If Cells(i, 6) <> Sheets(2).Cells(h, 1) And Cells(i, 6) <> Empty Then
                    
                       For chk = 2 To 16
                       
                           If Cells(i, 6) = Sheets(2).Cells(chk, 1) Then
                           
                               bdata = False
                               Exit For
                               
                           End If
                           
                       Next chk
                       
                       If bdata = True Then
                       
                           Range("a" & i).EntireRow.Delete
                           i = i - 1
                           
                       End If
                       
                    End If
                    
                    h = h + 1
                
                Loop
        
        Next
    
    .ScreenUpdating = True
    .DisplayAlerts = False
    
        fDir = ThisWorkbook.Path & "\new file.xlsx"
        ActiveWorkbook.SaveAs Filename:=fDir, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
            
    .DisplayAlerts = True
    
End With

End Sub

یا حق.

ممنون از راهنمایی تون استاد فقط اینکه آیا ميتونيم بجاي اينكه خط به خط يه صفحه تو اكسل رو با اين تابعي كه نوشتيم رو بررسي كنيم، كل ديتارو بفرستيم توي يه دونه متغير از جنس ارايه؟
طبق مدلی که شما فرمودید همچنان کندی سرعت اجرای ماکرو پابرجاس
ممنون میشم راهنمایی بفرمایید.

[mehdi.chatrbahr]

از اساتید ارجمند خواهشمندم پرسش بنده رو مورد مساعدت قرار بدن و راهنمایی لازم رو مزین فرمایند

[M_ExceL]

ممنون از راهنمایی تون استاد فقط اینکه آیا ميتونيم بجاي اينكه خط به خط يه صفحه تو اكسل رو با اين تابعي كه نوشتيم رو بررسي كنيم، كل ديتارو بفرستيم توي يه دونه متغير از جنس ارايه؟
طبق مدلی که شما فرمودید همچنان کندی سرعت اجرای ماکرو پابرجاس
ممنون میشم راهنمایی بفرمایید.

سلام، خواهش میکنم
کد زیر رو امتحان کنید ، همونطور که فرمودید اطلاعات به آرایه منتقل شده و بررسی می گردد و مشکل سرعت رفع گردید.
با کلیک روی باتن 1 ، اطلاعات به شیت 3 منتقل می شود.

Sub M_E()
Dim ar() As Variant
Dim ars() As Variant
Dim arsd() As Variant
Dim nar() As Variant
Dim nat() As Variant
Dim rng, rngs, rngsd As Range
Dim lr, i, s, t, p, sp, spd As Long
Dim brdata As Boolean
    lr = Cells(Rows.Count, 2).End(3).Row
    Set rng = Range("a2:l" & lr)
    Set rngs = Sheets(2).Range("a2:a16")
    Set rngsd = Sheets(2).Range("b2:b7")
    ar = rng.Value
    ars = rngs.Value
    arsd = rngsd.Value
        With Application
            .ScreenUpdating = False
                For i = 1 To 15
                
                    sp = sp + WorksheetFunction.CountIf(Range("f2:f" & lr), ars(i, 1))
                Next
                
            d = 0
            ReDim nar(1 To sp, 1 To 12)
            
                For i = 1 To 15
                    For s = 1 To lr - 1
                        If ars(i, 1) = ar(s, 6) Then
                            d = d + 1
                                For Z = 1 To 12
                                nar(d, Z) = ar(s, Z)
                            Next
                        End If
                    Next
                Next
                
                For i = 1 To 6
                    spd = spd + WorksheetFunction.CountIf(Range("j2:j" & lr), arsd(i, 1))
                Next
    
            spd = sp - spd
          
            ReDim nat(1 To spd, 1 To 12)
            p = 0
                                   For s = 1 To sp
                    
                                For t = 1 To 6

                                    If nar(s, 10) = arsd(t, 1) Then

                                         brdata = False
                                         
                                         Exit For
                                         Else
                                         brdata = True
                                    End If
                                
                                Next
                                If brdata = True Then
                                    p = p + 1
                                    
                                    For Z = 1 To 12
                                        nat(p, Z) = nar(s, Z)
                                    Next
                                 End If
                        
                    Next
          
            .ScreenUpdating = True
        End With
Sheets(3).Range("a1:l" & spd).Value = nat
End Sub

یاحق.

[mehdi.chatrbahr]

ممنون از همکاری و مساعدتون استاد
فقط من هرکاری کردم نتونستم این کدها رو بر اساس شرط جدیدم ادیت کنم و هربار تغییر میدادم ارور میگرفت، ممنون میشم راهنمایی بفرمائید چطور میتونم این کار رو انجام بدم.

[M_ExceL]

ممنون از همکاری و مساعدتون استاد
فقط من هرکاری کردم نتونستم این کدها رو بر اساس شرط جدیدم ادیت کنم و هربار تغییر میدادم ارور میگرفت، ممنون میشم راهنمایی بفرمائید چطور میتونم این کار رو انجام بدم.

سلام
کد زیر رو جایگزین کنید :

Sub M_E()
Dim ar() As Variant
Dim ars() As Variant
Dim arsd() As Variant
Dim nar() As Variant
Dim nat() As Variant
Dim nac() As Variant
Dim rng, rngs, rngsd, rngc  As Range
Dim lr, lr2, lr3, i, s, t, p, sp, spd As Long
Dim brdata As Boolean
    lr = Cells(Rows.Count, 2).End(3).Row
    lr2 = Sheets(2).Cells(Rows.Count, 1).End(3).Row
    lr3 = Sheets(2).Cells(Rows.Count, 2).End(3).Row
    Set rng = Range("a2:l" & lr)
    Set rngs = Sheets(2).Range("a2:a" & lr2)
    Set rngsd = Sheets(2).Range("b2:b" & lr3)
    ar = rng.Value
    ars = rngs.Value
    arsd = rngsd.Value
        With Application
            .ScreenUpdating = False
                For i = 1 To lr2 - 1
                    sp = sp + WorksheetFunction.CountIf(Range("f2:f" & lr), ars(i, 1))
                Next
            d = 0
            ReDim nar(1 To sp, 1 To 12)
            ReDim nac(1 To sp, 1 To 1)
                For i = 1 To lr2 - 1
                    For s = 1 To lr - 1
                        If ars(i, 1) = ar(s, 6) Then
                            d = d + 1
                                For Z = 1 To 12
                                    nar(d, Z) = ar(s, Z)
                                    nac(d, 1) = ar(s, 10)
                                Next
                        End If
                    Next
                Next
              Set rngc = Sheets(2).Range("d1:d" & sp)
                  rngc.Value = nac
               .ScreenUpdating = True
               .ScreenUpdating = False
                For i = 1 To lr3 - 1
                    spd = spd + WorksheetFunction.CountIf(rngc, arsd(i, 1))
                Next
            spd = sp - spd
            ReDim nat(1 To spd, 1 To 12)
            p = 0
                                   For s = 1 To sp
                    
                                For t = 1 To lr3 - 1

                                    If nar(s, 10) = arsd(t, 1) Or nar(s, 10) = Empty Then

                                         brdata = False
                                         
                                         Exit For
                                         Else
                                         brdata = True
                                    End If
                                
                                Next
                                If brdata = True Then
                                    p = p + 1
                                    
                                    For Z = 1 To 12
                                        nat(p, Z) = nar(s, Z)
                                    Next
                                 End If
                        
                    Next
          
            .ScreenUpdating = True
        End With
Sheets(3).Range("a1:l" & spd).Value = nat

End Sub

اکنون با اضافه یا کم کردن شروط ، کد به روز می گردد.

[M_ExceL]

سلام ،
آخرین تغییرات :
حلقه های اضافی حذف گردید و کد بهینه تر و سریعتر شد.

Sub M_E()
Dim ar() As Variant
Dim ars() As Variant
Dim arsd() As Variant
Dim nar() As Variant
Dim rng, rngs, rngsd  As Range
Dim lr, lr2, lr3, i, s, t, p, sp As Long
Dim brdata As Boolean
    lr = Cells(Rows.Count, 2).End(3).Row
    lr2 = Sheets(2).Cells(Rows.Count, 1).End(3).Row
    lr3 = Sheets(2).Cells(Rows.Count, 2).End(3).Row
    Set rng = Range("a2:l" & lr)
    Set rngs = Sheets(2).Range("a2:a" & lr2)
    Set rngsd = Sheets(2).Range("b2:b" & lr3)
    ar = rng.Value
    ars = rngs.Value
    arsd = rngsd.Value
        With Application
            .ScreenUpdating = False
                For i = 1 To lr2 - 1
                    sp = sp + WorksheetFunction.CountIf(Range("f2:f" & lr), ars(i, 1))
                Next
            p = 0
           
            ReDim nar(1 To sp, 1 To 12)
           
                For i = 1 To lr2 - 1
                    For s = 1 To lr - 1
                        If ars(i, 1) = ar(s, 6) Then
                            d = d + 1
                               
                               For t = 1 To lr3 - 1

                                    If arsd(t, 1) = ar(s, 10) Or ar(s, 10) = Empty Then

                                         brdata = False
                                         
                                         Exit For
                                         Else
                                         brdata = True
                                    End If
                                
                                Next
                                If brdata = True Then
                                    p = p + 1
                                    
                                    For Z = 1 To 12
                                        nar(p, Z) = ar(s, Z)
                                    Next
                                 End If
                               
    
                        End If
                    Next
                Next
          
            .ScreenUpdating = True
        End With
Sheets(3).Range("a1:l" & p).Value = nar

End Sub

یا حق.