VBA_ANCHECK

Sub AN_Check()



brr = Selection

Workbooks.Add

Dim book1 As Workbook

Set book1 = ActiveWorkbook


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
',FXM_USERS.FXM_EMAIL_ADDRESS,FXM_USERS.ADDPT_EMAIL_ADDRESS, JOB_STATUS.JOB_STATUS
'& " left join FXM_USERS on JOB_STATUS.EVENT_BY=FXM_USERS.FXM_USERNAME"

sql = "select distinct JOURNEY_SUMMARY.DISCH_IMP_VOYAGE, JOURNEY_SUMMARY.PORT_DISCH, JOURNEY_SUMMARY.JOB_REFERENCE, JOB_ADDRESSES.PARTNER_CODE, JOB_HEADERS.BOL_TYPE, JOB_HEADERS.JOB_STATUS,ARRIVAL_NOTICE_STATUSES.ARVN_STATUS,ARRIVAL_NOTICE_STATUSES.ARVN_STATUS_DATE, ARRIVAL_NOTICE_STATUSES.CONTACT_NUMBER" _
& " 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 JOB_STATUS on JOURNEY_SUMMARY.JOB_REFERENCE=JOB_STATUS.JOB_REFERENCE" _
& " left join ARRIVAL_NOTICE_STATUSES on ARRIVAL_NOTICE_STATUSES.BOL_NUMBER=JOURNEY_SUMMARY.JOB_REFERENCE" _
& " where JOURNEY_SUMMARY.DISCH_IMP_VOYAGE='" & brr(x, 1) & "'and JOURNEY_SUMMARY.PORT_DISCH='" & brr(x, 2) & "'and JOB_HEADERS.JOB_STATUS <> ('9')"
'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

If rs.EOF = False Then

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), "Carrier Website") + InStr(arr(8, i), "fax.") + InStr(arr(8, i), "FAX.") = 0 _
And arr(8, i) <> "") Or arr(4, 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(0 To UBound(arr1), 8)

j = 0


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(5, k) 'status
'arr3(j, 7) = arr(9, k) 'address 1
'arr3(j, 8) = arr(10, k) 'address 2

'arr3(j, 5) = arr(5, k) 'dp code


End If


Next k


j = j + 1

End If

Next i





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


If book1.Sheets(1).[a2] = "" Then

j = 2

Else

j = book1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).ROW + 1

End If

For i = 0 To UBound(arr1)

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

book1.Sheets(1).Cells(j, 1) = arr3(i, 1)
book1.Sheets(1).Cells(j, 2) = arr3(i, 2)
book1.Sheets(1).Cells(j, 3) = arr3(i, 3)
book1.Sheets(1).Cells(j, 4) = arr3(i, 4)
'Cells(j, 7) = arr3(i, 7)
'Cells(j, 8) = arr3(i, 8)
'Cells(j, 7) = arr3(i, 7)
'Cells(j, 8) = arr3(i, 8)
j = j + 1

End If

Next i




End If

dic.RemoveAll

End If

Next x


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:h1") = Array("No Email BL", "Import Voyage", "Port", "Status", "DP Code", "ETA", "address1", "address2")
Sheets(1).Name = "No AN Sent BL"
Cells.EntireColumn.AutoFit


'MsgBox "Check No Email BL"


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


MsgBox "Done"

End Sub