vba_emailcheck

Sub Email_Check()







brr = Selection

Dim conn As New Connection

'conn.Open "User ID=XXXX;Password=XXXX;Data Source=XXXXX;Provider=XXXXX"
 

'conn.Open "Provider=OraOLEDB.Oracle.1;User ID=XXXXX;Password=XXXX;Data Source=XXXXX;Persist Security Info=True"





        conn.Open "User ID=XXXX;Password=XXXX;Data Source=XXXXX;Provider=XXXXXX"

     'conn.Open "Provider=OraOLEDB.Oracle.1;User ID=XXXXXX;Password=XXXX;Data SourceXXXX;Persist Security Info=True"
   

 
 
 
'Dim Voyage, PORT As String
 
'Voyage = "'" & Voyage.TextBox1.Value & "'" '=Voyage.TextBox1.Value

'PORT = "'" & Voyage.TextBox2.Value & "'"       '=Voyage.TextBox2.Value


Dim sql, BOL As String


For x = 1 To UBound(brr)
'PORT_DISCH, JOURNEY_SUMMARY.JOB_REFERENCE,ADDRESS_TYPE,CONTACT_NUMBE
sql = "select  DISCH_IMP_VOYAGE, PORT_DISCH, JOURNEY_SUMMARY.JOB_REFERENCE, PARTNER_CODE,ADDRESS_TYPE,BOL_TYPE,JOB_HEADERS.JOB_STATUS,JOB_ADDRESSES.ADDR_CODE,CONTACT_NUMBER,CONTACT_NUM_TYPE,JOB_STATUS.JOB_STATUS as JOB_STATUS_change,JOB_STATUS.EVENT_BY,FXM_USERS.FXM_USERNAME,FXM_USERS.FXM_EMAIL_ADDRESS,FXM_USERS.ADDPT_EMAIL_ADDRESS" _
& " from JOURNEY_SUMMARY inner join JOB_ADDRESSES on JOURNEY_SUMMARY.JOB_REFERENCE=JOB_ADDRESSES.JOB_REFERENCE" _
& " inner join JOB_HEADERS on JOURNEY_SUMMARY.JOB_REFERENCE=JOB_HEADERS.JOB_REFERENCE" _
& " left join ADDRESS_CONTACT_NUMBERS on JOB_ADDRESSES.ADDR_CODE=ADDRESS_CONTACT_NUMBERS.ADDR_CODE" _
& " left join JOB_STATUS on JOURNEY_SUMMARY.JOB_REFERENCE=JOB_STATUS.JOB_REFERENCE" _
& " left join FXM_USERS on JOB_STATUS.EVENT_BY=FXM_USERS.FXM_USERNAME" _
& " where DISCH_IMP_VOYAGE='" & brr(x, 1) & "'and PORT_DISCH='" & brr(x, 2) & "'and ADDRESS_TYPE in ('CEE','NOT','NO2') and JOB_HEADERS.JOB_STATUS <> ('9') and JOB_STATUS.JOB_STATUS in ('1','20')"
'rownum <='10'  /   BOL_NUMBER ='AFB0156681'  /  JOB_REFERENCE='AUV0114377'

Dim rs As New ADODB.Recordset


Set rs = conn.Execute(sql)


'Next i


'For i = 0 To rs.Fields.Count - 1
'Cells(1, i + 1) = rs.Fields(i).Name
'Next i
'range("a2").CopyFromRecordset rs

arr = rs.GetRows

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

Dim dic

Set dic = CreateObject("scripting.dictionary")


For i = 0 To UBound(arr, 2)


dic(arr(2, i)) = 0

Next i


For i = 0 To UBound(arr, 2)


If arr(3, i) <> "9999999901" And arr(3, i) <> "9999999902" And InStr(arr(8, i), "@cma") + InStr(arr(8, i), "@CMA") + InStr(arr(8, i), "fax.") + InStr(arr(8, i), "FAX.") = 0 _
And arr(8, i) <> "" And arr(9, i) = "EM" Or arr(5, i) = "M" Then   'Or arr(5, i) = "M"

dic(arr(2, i)) = dic(arr(2, i)) + 1

End If

Next i



arr1 = dic.Keys
arr2 = dic.Items



Dim arr3()
ReDim arr3(1 To UBound(arr1), 7)

j = 1


For i = 0 To UBound(arr1)

If arr2(i) = 0 Then

arr3(j, 1) = arr1(i)


'加入Import port
For k = 0 To UBound(arr, 2)

If arr(2, k) = arr3(j, 1) Then

arr3(j, 2) = arr(0, k) 'voyage
arr3(j, 3) = arr(1, k) 'port
'arr3(j, 4) = arr(4, k) 'eta
'arr3(j, 5) = arr(5, k) 'dp code
arr3(j, 6) = arr(13, k) 'address1
arr3(j, 7) = arr(14, k) 'address2

End If


Next k


j = j + 1

End If

Next i



If arr3(1, 1) <> "" Then

Workbooks.Add

Dim book1 As Workbook

Set book1 = ActiveWorkbook

j = 2

For i = 1 To UBound(arr1)

If arr3(i, 1) <> "" Then

Cells(j, 1) = arr3(i, 1)
Cells(j, 2) = arr3(i, 2)
Cells(j, 3) = arr3(i, 3)
Cells(j, 4) = arr3(i, 4)
Cells(j, 5) = arr3(i, 5)
Cells(j, 6) = arr3(i, 6)
Cells(j, 7) = arr3(i, 7)
j = j + 1

End If

Next i

book1.Sheets(1).[a1].Select

'dp code

  Set con = CreateObject("adodb.connection")
    Set rst = CreateObject("ADODB.recordset")
 
    con.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$]", con, adOpenKeyset, adLockOptimistic
  
    On Error Resume Next
    
For X1 = 2 To Range("a65536").End(xlUp).ROW

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

Cells(X1, "e") = rst.Fields(Cells(X1, "c") & Right(Cells(X1, "b").Value, 2))

Else

Cells(X1, "e") = rst.Fields(Cells(X1, "c") & "MA")

End If

Next X1

  On Error GoTo 0



Range("a1:g1") = Array("No Email BL", "Import Voyage", "Port", "ETA", "DP Code", "Status1_ADDRESS", "Status20_ADDRESS")
Sheets(1).Name = [b2] & "-" & [c2]
Cells.EntireColumn.AutoFit


'MsgBox "Check No Email BL"


End If

dic.RemoveAll

Next x

rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing


MsgBox "Done"

End Sub