[حل شده] درخواست راهنمایی اضطراری در خصوص مشکل ماکرو

[mehdi.chatrbahr]

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


کد:

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

[misammisam]

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

Private Sub CommandButton1_Click()
    Sheets("sheet1").Range("Table[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("A2:M17"), CopyToRange:=Range("A19"), Unique:=False
    ActiveWindow.SmallScroll Down:=6
End Sub 

[M_ExceL]

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


کد:

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

سلام،
پاسخ شما در تاپیک قبلی داده شد، امیدوارم مشکلتون رو حل کنه،
یا حق.