vba_undeliverable_email_check

Sub UndeCheck()

'fuzhi list

Dim MyBook2 As Workbook
Set MyBook2 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "\\cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\13 Undeliverable E-mail"
    .AllowMultiSelect = False
    .Filters.Clear
    .Filters.Add "Text File", "*.txt"
    .Filters.Add "EXCEL File", "*.xlsx; *.xls", 1
    .Filters.Add "All File", "*.*", 1
    If .Show Then
        .ButtonName = "Select Me"
        Set ipath = .SelectedItems
    End If
End With

If IsEmpty(ipath) Then Exit Sub
ipath = ipath(1)

Dim MyBook1 As Workbook
Set MyBook1 = Workbooks.Open(ipath)
MyBook1.Sheets("Go").Copy MyBook2.Sheets("Page1_1")
MyBook1.Close

'tiqu undi


Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")

Dim undi, undi8()

Dim un, un8, rowx As Integer
rowx = Range("a65536").End(xlUp).ROW

For un = 1 To rowx
ReDim undi8(1 To rowx, 1)
undi = Cells(un, "a")


With reg

.Global = False
.Pattern = "[A-Z]{3}\w\d{6}[A-Z]{0,2}[A-Z]{3}\w\d{6}[A-Z]{0,2}"

If undi <> Empty And undi <> " " Then

On Error Resume Next
undi8(un, 1) = .Execute(undi)(0)
un8 = Len(undi8(un, 1)) / 2
Cells(un, "b") = Left(undi8(un, 1), un8)
On Error GoTo 0

End If

End With

Next un


'undi BL quchong

Dim dic
Set dic = CreateObject("scripting.dictionary")

Dim undi1
Dim u, rowb As Integer

rowb = Range("b65536").End(xlUp).ROW
undi1 = Range(Cells(1, 2), Cells(rowb, 2))

For u = 1 To rowb
dic(undi1(u, 1)) = ""
Next u

Range("c1").Resize(dic.Count) = Application.Transpose(dic.Keys)

'tiqu AN sent BL

Dim ROW1 As Integer
Dim ANsent()
ROW1 = Sheets("Page1_1").Cells.Find("*", , , , , xlPrevious).ROW
ReDim ANsent(1 To ROW1, 1 To 3)
Dim a As Integer
For a = 1 To ROW1
If Sheets("Page1_1").Range("a" & a).Value = "Pre Arrival Sent" Or Sheets("Page1_1").Range("a" & a).Value = "Standard" Or Sheets("Page1_1").Range("a" & a).Value = "Canadian Pre Arrival Sent" Then
ANsent(a, 2) = Sheets("Page1_1").Range("k" & a)
End If
If InStr(ANsent(a, 2), "Carrier Website") + InStr(ANsent(a, 2), "fax.") + InStr(ANsent(a, 2), "FAX.") = 0 And ANsent(a, 2) <> "" Then
ANsent(a, 3) = Sheets("Page1_1").Range("b" & a)
End If
Range("d" & a) = ANsent(a, 3)
Next a


'bijiao

Dim bj

For bj = 1 To dic.Count
Cells(bj, "e") = WorksheetFunction.CountIf(Columns("B:B"), Cells(bj, "c"))
Cells(bj, "f") = WorksheetFunction.CountIf(Columns("D:D"), Cells(bj, "c"))
If Cells(bj, "e") >= Cells(bj, "f") And Cells(bj, "f") <> 0 Then
Cells(bj, "l") = Cells(bj, "c")
End If
Next bj

'没发通的BL到L列 去重复到G列

Dim f
Set f = CreateObject("scripting.dictionary")

For qk1 = 1 To Range("l65536").End(xlUp).ROW
If Range("l" & qk1) <> "" Then
f(Range("l" & qk1)) = ""
End If
Next qk1

If f.Count <> 0 Then
Range("g1").Resize(f.Count) = Application.Transpose(f.Keys)
End If

f.RemoveAll
dic.RemoveAll


'格式整理

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    [a1] = "Undeliverable Email"
    [b1] = "Undeliverable Email BL"
    [c1] = "Undeliverable BL"
    [d1] = "ANsent BL"
    [e1] = "COUNTIF(B,C)"
    [F1] = "COUNTIF(D,C)"
    [G1] = "Need Check BL"
    ActiveSheet.Name = "UndeliverableCheck"
     Range("a1:g1").Interior.ColorIndex = 36
     
     
Cells.EntireColumn.AutoFit
    Range("1:1,B:B").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
Columns("B:F").Delete
Columns("G:H").Delete
    
    MsgBox "Done"
 
End Sub