vba_emailcheck02

最新推荐文章于 2025-05-21 23:09:37 发布

fuchouqiong

最新推荐文章于 2025-05-21 23:09:37 发布

阅读量564

点赞数

分类专栏： VBA 文章标签： sql

本文链接：https://blog.youkuaiyun.com/fuchouqiong/article/details/120331554

版权

VBA 专栏收录该内容

15 篇文章

订阅专栏

Sub Emcheck()

'if part code bushi 99991 and email addres bu han "@fax or @FAX or @cma or @CMA"

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

For x = 11 To Range("a65536").End(xlUp).ROW


dic(Cells(x, "a").Value) = 0

Next x

For x = 11 To Range("a65536").End(xlUp).ROW


If (Cells(x, "c") <> "9999999901" And Cells(x, "c") <> "9999999902" And InStr(Cells(x, "e"), "@cma") + InStr(Cells(x, "e"), "@CMA") + InStr(Cells(x, "E"), "fax.") + InStr(Cells(x, "E"), "FAX.") = 0 And _
Cells(x, "e") <> "") Or InStr(Cells(x, "D"), "CMA CGM") + InStr(Cells(x, "D"), "ANL CHINA LIMITED") + InStr(Cells(x, "D"), "CMA SHIPS") + InStr(Cells(x, "D"), "CMA-CGM") >= 1 Then

dic(Cells(x, "a").Value) = dic(Cells(x, "a").Value) + 1

End If

Next x

Range("Q11").Resize(dic.Count) = Application.Transpose(dic.Keys)
Range("R11").Resize(dic.Count) = Application.Transpose(dic.Items)

dic.RemoveAll



For Y = 11 To Range("Q65536").End(xlUp).ROW

  On Error Resume Next

If Cells(Y, "R") = 0 Then

Cells(k + 11, "k") = Cells(Y, "Q")
Cells(k + 11, "L") = Range("A:A").Find(Cells(Y, "Q")).Offset(0, 7)
Cells(k + 11, "M") = Range("A:A").Find(Cells(Y, "Q")).Offset(0, 8)
Cells(k + 11, "N") = Range("A:A").Find(Cells(Y, "Q")).Offset(0, 9)

k = k + 1

End If

Next Y

'cha zhao dpcode


    Set conn = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
 
    conn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & "C:\Users\GSC.BFU\Desktop\bOB\SHA Email Ask Atuo\DP Code.xlsx"
    
  
  rst.Open "select *  from [Sheet1$]", conn, adOpenKeyset, adLockOptimistic
  




For X1 = 11 To Range("K65536").End(xlUp).ROW

If Len(Cells(X1, "l")) > 6 Then

Cells(X1, "O") = rst.Fields(Cells(X1, "m") & Right(Cells(X1, "L"), 2))

Else

Cells(X1, "O") = rst.Fields(Cells(X1, "m") & "MA")

End If

Next X1


    rst.Close
    conn.Close
    Set rst = Nothing
    Set conn = Nothing

  On Error GoTo 0
  
Columns("Q:R").Delete

[k10] = "NO EMAIL BL"
[l10] = "Import Voyage"
[m10] = "Port"
[n10] = "ETA"
[O10] = "DP Code"

Range("K10:O10").Interior.ColorIndex = 36



Columns("N").NumberFormat = "m/d/yyyy"
Columns("K:O").EntireColumn.AutoFit

MsgBox "done"


End Sub