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

[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
سلام،
پاسخ شما در تاپیک قبلی داده شد، امیدوارم مشکلتون رو حل کنه،
یا حق.