-
Tim và thay thế trong text filel thỏa mãn 2 điều kiện biến đổi theo giá trị của ô
[IMG]images/smilies/a36.gif[/IMG] Kính nhờ các ACE cao thủ GPE giúp em việc này.
Em có 1 file danh sách hàng ngàn email, và em muốn lọc bỏ những địa chỉ email thỏa mãn điều kiện cho trước ở 2 cột cho trước.
Em gửi kèm mẫu.
Cảm ơn rất nhiều.
Sub Testing_Removal_matching_Email()
'Declare ALL of your variables
Dim i As Long, searchString As String
Dim repLine As Variant 'the array of lines you will WRITE
Dim ln As Variant
Dim l As Long
'Mo file va doc file nguon
'--------------------------------------------------
Dim readFile As Object 'the file you will READ
Const fileToRead As String = "C:\Documents and Settings\Admin\Desktop\TESTING\test.txt" ' the path of the file to read
Const ForReading = 1 '
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set readFile = FSO.OpenTextFile(fileToRead, ForReading, False)
repLine = Split(readFile.ReadAll, vbNewLine)
readFile.Close
'--------------------------------------------------
'Tao file dich de chep du lieu
'--------------------------------------------------
Dim writeFile As Object 'the file you will CREATE
Const fileToWrite As String = "C:\Documents and Settings\Admin\Desktop\TESTING\test_NEW.txt" ' the path of a new file
Set FSO = CreateObject("Scripting.FileSystemObject")
Set writeFile = FSO.CreateTextFile(fileToWrite, True, False)
'--------------------------------------------------
'Tao MyDic1, MyDic2 tu 2 cot trong Sheet("Key")
'--------------------------------------------------
Dim NameDic As Object, DomainDic As Object
Dim dArr1(), dArr2(), d1, d2, dPrice()
EndR = [a65000].End(xlUp).Row
dArr1 = Worksheets("Key").Range("A1:A" & EndR).Value
dArr2 = Worksheets("Key").Range("c2:c" & EndR).Value
Set NameDic = CreateObject("scripting.dictionary")
Set DomainDic = CreateObject("scripting.dictionary")
'--------------------------------------------------
'So sanh repLine voi NameDic va Cot D (Domain) voi DomainDic
'--------------------------------------------------
For Each d1 In dArr1
NameRepLine = Left(d1, Find("@", d1) - 1) 'Trich Name cua Email
If d1 <> "" And d1 = IIf(NameRepLine = NameDic, "", d1) Then
repLine(l) = d1
l = l + 1
End If
Next d1
For Each d2 In dArr2
DomainRepLine = Mid(d2, Find("@", d2, 1) + 1, 255) 'Trich Domain cua Email
If d2 <> "" And d2 = IIf(InStr(1, DomainRepLine, DomainDic, vbTextCompare) > 0, "", d2) Then
repLine(l) = d2
l = l + 1
End If
Next d2
'--------------------------------------------------
'# Write to the array items to the file
writeFile.Write Join(repLine, vbNewLine)
writeFile.Close
'# clean up
Set readFile = Nothing
Set writeFile = Nothing
Set FSO = Nothing
End Sub
View more random threads:
Quyền viết bài
- Bạn Không thể gửi Chủ đề mới
- Bạn Không thể Gửi trả lời
- Bạn Không thể Gửi file đính kèm
- Bạn Không thể Sửa bài viết của mình
-
Nội quy - Quy định