VBA宏程序

1.VBA宏程序截图

1.1 VBA自动加工EXCEL进行时

https://v.youku.com/v_show/id_XNTg0NzgyNjI5Mg==.html

1.2 VBA加载加工ORACLE数据，并自动发送邮件进行时

https://v.youku.com/v_show/id_XNTg0NzgzMDkwOA==.html

1.3 VBA宏程序汇总

2.VBA常用模块

2.1 读取excel

Sub OpenFile()

'fuzhi xuyao biaoge
Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook



With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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 MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook2 = Workbooks.Open(ipath)
MyBook2.Sheets("Page1_1").Copy MyBook1.Sheets("page")
MyBook2.Close
MyBook1.Sheets("Page1_1").Name = "ETD"



Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\LTAM Schedule Atuo\LTAM Schedule History.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("page")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Schedule"



Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\LTAM Schedule Atuo\LTAM PIC.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("page")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "PIC"



End Sub

2.2 excel格式整理

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

2.3 正则表达式

Sub Regular_ex()

'正则表达式

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

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)        '以.Pattern为规则用.Execute提取(undi)(0)的值到undi8(un, 1)
un8 = Len(undi8(un, 1)) / 2
Cells(un, "b") = Left(undi8(un, 1), un8)
On Error GoTo 0

End If

End With


End Sub

2.4 自动发送邮件

Sub SendEmail()


For i = 2 To Sheets("1-20 Email Address").range("H65536").End(xlUp).Row


Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets("1-20 Email Address").Cells(i, "H")
ETA = Sheets("1-20 Email Address").Cells(i, "l")
T = Sheets("1-20 Email Address").Cells(i, "M")
DPc = Sheets("1-20 Email Address").Cells(i, "K")


With outlookitem

.Display

.To = T
.CC = "GSC.BFU@cma-cgm.com;gsc.northchinaimport@cma-cgm.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody

End With

Set outlookitem = Nothing
Set y = Nothing

Next i

Set outlookapp = Nothing

End Sub

2.5 操作aceess数据库

Sub Database()

'连接数据库

Dim conn As New Connection

 conn.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "C:\Users\GSC.BFU\Desktop\VBA1\数据库\New Microsoft Access Database - Copy.accdb"

'sql 筛选数据

Dim sql As String

sql = "select * from WK42"

'将结果提取到数据集

Set rs = conn.Execute(sql)

'使用rs.find查找符合条件的数据并输出到单元格

Dim IV

For i = 6 To range("d65536").End(xlUp).Row

IV = Cells(i, "E")

rs.Find "ImportVoyage= '" & IV & "'", , , 1       '查询import voyage 是IN的船

Cells(i, "C") = rs.Fields(0)                      'rs.Fields(0)第一列的内容输出到单元格

Next i

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


    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=" & "\\cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\SHA Email Ask Atuo\DP Code.xlsx"
    
  
  
  rst.Open "select *  from [Sheet1$]", conn, adOpenKeyset, adLockOptimistic
  
    On Error Resume Next
For X1 = 3 To range("a65536").End(xlUp).Row

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

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



End Sub

2.6 宏破解

Option Explicit
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Long, Source As Long, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
         
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
    
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, ByVal pTemplateName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
         
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean
*************************************************************
Private Function GetPtr(ByVal Value As Long) As Long
    GetPtr = Value
End Function
**************************************************************
Public Sub RecoverBytes()
    If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub
*************************************************************
Public Function Hook() As Boolean
    Dim TmpBytes(0 To 5) As Byte
    Dim p As Long
    Dim OriginProtect As Long
    
    Hook = False
    pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
    If VirtualProtect(ByVal pFunc, 6, &H40, OriginProtect) <> 0 Then
        MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
        If TmpBytes(0) <> &H68 Then
            MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
            p = GetPtr(AddressOf MyDialogBoxParam)
            HookBytes(0) = &H68
            MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
            HookBytes(5) = &HC3
            MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
            Flag = True
            Hook = True
        End If
    End If
End Function
*****************************************************
Private Function MyDialogBoxParam(ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
    If pTemplateName = 4070 Then
        MyDialogBoxParam = 1
    Else
        RecoverBytes
        MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, hWndParent, lpDialogFunc, dwInitParam)
        Hook
    End If
End Function
******************************************************

2.7 VBA字典

Sub dic()


Dim dic

Set dic = CreateObject("scripting.dictionary")

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

range("h2").Resize(dic.Count) = Application.Transpose(dic.Keys)    '以[h2]为顶点，输出字典dic的key值
range("i2").Resize(dic.Count) = Application.Transpose(dic.Items)   '以[h2]为顶点，输出字典dic的item值

[a1] = dic.Count


'字典的方法，有Add、Exists、Keys、Items、Remove、RemoveAll
'字典的属性 有Count、Key、Item、ConpareMode四种属性

End Sub

3.VBA实例代码

3.1 ALL_AN_CHECK

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

3.2 EMAIL_CHECK

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

3.3 Pre_Discharge_Report

Sub Pre_Discharge_Report()

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 sql As String

sql = "select Port & Voyage as PV,STA from Ship_Angecy"

Set rs = conn.Execute(sql)





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


Dim MyBook1, MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "\\CNGSCAPL-SPF303\Customer_Care\Doc_Import\Share\CN_Import\03NON-SHA\03 Report\02 ICC"
    .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)

Set MyBook2 = Workbooks.Open(ipath)

crr = MyBook2.Sheets("Pre-Discharge").[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)
drr = MyBook2.Sheets("ICC").[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

Dim dic, dic1, dic2, dic3
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")


For i = 1 To UBound(crr)

dic(crr(i, 2)) = crr(i, 12)

Next i


For i = 1 To UBound(drr)

dic1(drr(i, 2)) = drr(i, 12)

Next i


MyBook2.Close

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\pre-discharge\Find_PIC.xlsx")

Set MyBook3 = ActiveWorkbook

crr1 = MyBook3.Sheets(1).[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

For i = 2 To UBound(crr1)

dic2(crr1(i, 1)) = crr1(i, 2)

dic3(crr1(i, 3)) = crr1(i, 4)

Next i

MyBook3.Close


MyBook1.Sheets("Sheet1").Select


arr = [a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

For i = 2 To UBound(arr)
If (arr(i, 14) <> "CNSIA" And arr(i, 14) <> "CNCTU" And arr(i, 14) <> "CNWUX" And arr(i, 14) <> "CNCGO" And arr(i, 14) <> "CNSHA" _
 And arr(i, 14) <> "CNTAO" And arr(i, 14) <> "CNTXG" And arr(i, 14) <> "CNNGB" And arr(i, 14) <> "CNDLC" And Left(arr(i, 14), 2) <> "KZ" _
And Left(arr(i, 14), 2) <> "KG" And Left(arr(i, 14), 2) <> "MN" And Left(arr(i, 14), 2) <> "UZ" And arr(i, 14) <> "") And 0 < Len(arr(i, 6)) < 9 Then
arr(i, 13) = arr(i, 14)
End If

If (arr(i, 14) <> "CNSIA" And arr(i, 14) <> "CNCTU" And arr(i, 14) <> "CNWUX" And arr(i, 14) <> "CNCGO" And arr(i, 14) <> "CNSHA" _
 And arr(i, 14) <> "CNTAO" And arr(i, 14) <> "CNTXG" And arr(i, 14) <> "CNNGB" And arr(i, 14) <> "CNDLC" And Left(arr(i, 14), 2) <> "KZ" _
And Left(arr(i, 14), 2) <> "KG" And Left(arr(i, 14), 2) <> "MN" And Left(arr(i, 14), 2) <> "UZ" And arr(i, 14) <> "") And Len(arr(i, 6)) = 9 Then
arr(i, 1) = ""
End If
Next i

Dim brr
ReDim brr(UBound(arr), 13)
k = 1
For i = 2 To UBound(brr)
If arr(i, 10) = arr(i, 13) And InStr(arr(i, 7), "tbn") + InStr(arr(i, 7), "TBN") = 0 And arr(i, 1) <> "" And CDate(arr(i, 15)) < CDate(Evaluate("=TODAY()")) And DateAdd("m", -5, CDate(Evaluate("=TODAY()"))) < CDate(arr(i, 15)) _
And arr(i, 13) <> "CNAQG" _
And arr(i, 13) <> "CNCGU" _
And arr(i, 13) <> "CNCZ1" _
And arr(i, 13) <> "CNCZX" _
And arr(i, 13) <> "CNDFE" _
And arr(i, 13) <> "CNHFE" _
And arr(i, 13) <> "CNJIA" _
And arr(i, 13) <> "CNMAA" _
And arr(i, 13) <> "CNNKG" _
And arr(i, 13) <> "CNNTG" _
And arr(i, 13) <> "CNRUG" _
And arr(i, 13) <> "CNTOL" _
And arr(i, 13) <> "CNTZO" _
And arr(i, 13) <> "CNWHI" _
And arr(i, 13) <> "CNYZH" _
And arr(i, 13) <> "CNZHE" _
And arr(i, 13) <> "CNZJG" _
And arr(i, 13) <> "CNLZU" _
And arr(i, 13) <> "CNCKG" _
And arr(i, 13) <> "CNWUH" _
And arr(i, 13) <> "CNCLJ" _
And arr(i, 13) <> "CNJIU" And arr(i, 13) <> "CNCDE" And arr(i, 13) <> "CNJGZ" And arr(i, 13) <> "CNQZH" And arr(i, 13) <> "CNSHA" _
And arr(i, 13) <> "CNTAG" And arr(i, 13) <> "CNYBN" And arr(i, 13) <> "CNCSX" And arr(i, 13) <> "CNHSI" And arr(i, 13) <> "CNYUY" And arr(i, 13) <> "CNKHN" And arr(i, 13) <> "CNCTU" And arr(i, 13) <> "CNYIC" _
Then
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 6)
brr(k, 4) = arr(i, 7)
brr(k, 5) = arr(i, 8)
brr(k, 6) = arr(i, 9)
brr(k, 7) = arr(i, 13)
brr(k, 8) = arr(i, 14)
brr(k, 9) = arr(i, 15)
brr(k, 10) = arr(i, 12)

IV = arr(i, 13) & Left(arr(i, 6), 3)

On Error Resume Next

rs.Find "PV= '" & IV & "'", , , 1

brr(k, 13) = rs.Fields(0)

On Error GoTo 0

If dic2.exists(arr(i, 1) & arr(i, 10)) Then

brr(k, 12) = dic2(arr(i, 1) & arr(i, 10))

ElseIf dic3.exists(arr(i, 10)) And brr(k, 12) = "" Then

brr(k, 12) = dic3(arr(i, 10))

End If




If dic.exists(arr(i, 2)) Then

brr(k, 11) = dic(arr(i, 2))

ElseIf dic1.exists(arr(i, 2)) Then

brr(k, 11) = dic1(arr(i, 2))

End If




k = k + 1
End If

Next i



Sheets.Add
ActiveSheet.Name = "Status 20"
Sheets.Add
ActiveSheet.Name = "Pre-Discharge"
Sheets.Add
ActiveSheet.Name = "ICC"


Sheets("Status 20").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")
Sheets("Pre-Discharge").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")
Sheets("ICC").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")


k = 2
l = 2
m = 2

For i = 2 To UBound(brr)

If brr(i, 5) = 20 Then

Sheets("Status 20").Cells(k, 1) = brr(i, 1)
Sheets("Status 20").Cells(k, 2) = brr(i, 2)
Sheets("Status 20").Cells(k, 3) = brr(i, 3)
Sheets("Status 20").Cells(k, 4) = brr(i, 4)
Sheets("Status 20").Cells(k, 5) = brr(i, 5)
Sheets("Status 20").Cells(k, 6) = brr(i, 6)
Sheets("Status 20").Cells(k, 7) = brr(i, 7)
Sheets("Status 20").Cells(k, 8) = brr(i, 8)
Sheets("Status 20").Cells(k, 9) = brr(i, 9)
Sheets("Status 20").Cells(k, 10) = brr(i, 10)
Sheets("Status 20").Cells(k, 13) = brr(i, 11)
Sheets("Status 20").Cells(k, 11) = brr(i, 12)
Sheets("Status 20").Cells(k, 12) = brr(i, 13)

k = k + 1

ElseIf brr(i, 5) = 30 Then

Sheets("Pre-Discharge").Cells(l, 1) = brr(i, 1)
Sheets("Pre-Discharge").Cells(l, 2) = brr(i, 2)
Sheets("Pre-Discharge").Cells(l, 3) = brr(i, 3)
Sheets("Pre-Discharge").Cells(l, 4) = brr(i, 4)
Sheets("Pre-Discharge").Cells(l, 5) = brr(i, 5)
Sheets("Pre-Discharge").Cells(l, 6) = brr(i, 6)
Sheets("Pre-Discharge").Cells(l, 7) = brr(i, 7)
Sheets("Pre-Discharge").Cells(l, 8) = brr(i, 8)
Sheets("Pre-Discharge").Cells(l, 9) = brr(i, 9)
Sheets("Pre-Discharge").Cells(l, 10) = brr(i, 10)
Sheets("Pre-Discharge").Cells(l, 13) = brr(i, 11)
Sheets("Pre-Discharge").Cells(l, 11) = brr(i, 12)
Sheets("Pre-Discharge").Cells(l, 12) = brr(i, 13)

l = l + 1

ElseIf brr(i, 5) = 60 Then

Sheets("ICC").Cells(m, 1) = brr(i, 1)
Sheets("ICC").Cells(m, 2) = brr(i, 2)
Sheets("ICC").Cells(m, 3) = brr(i, 3)
Sheets("ICC").Cells(m, 4) = brr(i, 4)
Sheets("ICC").Cells(m, 5) = brr(i, 5)
Sheets("ICC").Cells(m, 6) = brr(i, 6)
Sheets("ICC").Cells(m, 7) = brr(i, 7)
Sheets("ICC").Cells(m, 8) = brr(i, 8)
Sheets("ICC").Cells(m, 9) = brr(i, 9)
Sheets("ICC").Cells(m, 10) = brr(i, 10)
Sheets("ICC").Cells(m, 13) = brr(i, 11)
Sheets("ICC").Cells(m, 11) = brr(i, 12)
Sheets("ICC").Cells(m, 12) = brr(i, 13)


m = m + 1


End If

Next i

Sheets("ICC").Cells.EntireColumn.AutoFit
Sheets("Pre-Discharge").Cells.EntireColumn.AutoFit
Sheets("Status 20").Cells.EntireColumn.AutoFit

MsgBox "Done"

End Sub

3.4 APL-findpic()

Sub findpic()



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 sql As String

sql = "select * from WK42"



Set rs = conn.Execute(sql)



Dim IV

For i = 6 To Range("d65536").End(xlUp).ROW

IV = Cells(i, "E")

rs.Find "ImportVoyage= '" & IV & "'", , , 1

Cells(i, "C") = rs.Fields(0)

Next i


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


End Sub

3.5 STATUS_FIND

Sub FINDStatus()



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 = 2 To Cells(Rows.Count, 1).End(xlUp).ROW



'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 JOB_STATUS.JOB_REFERENCE, JOB_STATUS.JOB_STATUS, JOB_STATUS.EVENT_BY, FXM_EMAIL_ADDRESS, ADDPT_EMAIL_ADDRESS" _
& " from JOB_STATUS left join FXM_USERS on JOB_STATUS.EVENT_BY=FXM_USERS.FXM_USERNAME" _
& " where JOB_STATUS.JOB_REFERENCE='" & Cells(x, 1) & "' " '" & arr(x,1) & "
'rownum <='10'  /   BOL_NUMBER ='AFB0156681'  /  JOB_REFERENCE='AUV0114377'

Dim rs As New ADODB.Recordset


Set rs = conn.Execute(sql)

arr = rs.GetRows

Cells(x, 7) = arr(3, 1)

Cells(x, 8) = arr(4, 1)

Next x



End Sub

3.6 toolshow

Sub toolshow()
    LaraFit.Show
End Sub
***************


Sub Add_InboundFit_Menu()


Dim cbWSMenuBar As CommandBar
Dim muInbound As CommandBarControl
Dim iHelpIndex As Integer



Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
iHelpIndex = cbWSMenuBar.Controls("Help").Index


Set muInbound = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, BEFORE:=iHelpIndex, Temporary:=False)

With muInbound
    .Caption = "LaraFit"
    With .Controls.Add '(Type:=msoControlPopup)
        .Caption = "Open LaraFit"
        .OnAction = "toolshow"
    End With
End With


End Sub

3.7 NC_Remark_Delete

Sub remark_delete()

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\11111111\EDI_LARA\1208"
    .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)


Workbooks.OpenText Filename:=ipath, Space:=False, Semicolon:=False


For i = 1 To Range("a65536").End(xlUp).ROW

If Left(Cells(i, 1), 10) = "20:REMARK:" Then


Cells(i, 1) = "20:REMARK: :::::'"

End If

Next i



ActiveWorkbook.SaveAs ipath

ActiveWorkbook.Close



MsgBox "Done"


End Sub

3.8 NC_Predischarge

Sub Pre_Discharge_Report()

Dim MyBook1, MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "\\CNGSCAPL-SPF303\Customer_Care\Doc_Import\Share\CN_Import\03NON-SHA\03 Report\02 ICC"
    .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)

Set MyBook2 = Workbooks.Open(ipath)

crr = MyBook2.Sheets("Pre-Discharge").[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)
drr = MyBook2.Sheets("ICC").[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

Dim dic, dic1, dic2, dic3
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")


For i = 1 To UBound(crr)

dic(crr(i, 2)) = crr(i, 12)

Next i


For i = 1 To UBound(drr)

dic1(drr(i, 2)) = drr(i, 12)

Next i


MyBook2.Close

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\pre-discharge\Find_PIC.xlsx")

Set MyBook3 = ActiveWorkbook

crr1 = MyBook3.Sheets(1).[a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

For i = 2 To UBound(crr1)

dic2(crr1(i, 1)) = crr1(i, 2)

dic3(crr1(i, 3)) = crr1(i, 4)

Next i

MyBook3.Close


MyBook1.Sheets("Sheet1").Select


arr = [a1].Resize(Cells(Rows.Count, 1).End(xlUp).ROW, Cells(1, Columns.Count).End(xlToLeft).Column)

For i = 2 To UBound(arr)
If (arr(i, 14) <> "CNSIA" And arr(i, 14) <> "CNCTU" And arr(i, 14) <> "CNWUX" And arr(i, 14) <> "CNCGO" And arr(i, 14) <> "CNSHA" _
 And arr(i, 14) <> "CNTAO" And arr(i, 14) <> "CNTXG" And arr(i, 14) <> "CNNGB" And arr(i, 14) <> "CNDLC" And Left(arr(i, 14), 2) <> "KZ" _
And Left(arr(i, 14), 2) <> "KG" And Left(arr(i, 14), 2) <> "MN" And Left(arr(i, 14), 2) <> "UZ" And arr(i, 14) <> "") And 0 < Len(arr(i, 6)) < 9 Then
arr(i, 13) = arr(i, 14)
End If

If (arr(i, 14) <> "CNSIA" And arr(i, 14) <> "CNCTU" And arr(i, 14) <> "CNWUX" And arr(i, 14) <> "CNCGO" And arr(i, 14) <> "CNSHA" _
 And arr(i, 14) <> "CNTAO" And arr(i, 14) <> "CNTXG" And arr(i, 14) <> "CNNGB" And arr(i, 14) <> "CNDLC" And Left(arr(i, 14), 2) <> "KZ" _
And Left(arr(i, 14), 2) <> "KG" And Left(arr(i, 14), 2) <> "MN" And Left(arr(i, 14), 2) <> "UZ" And arr(i, 14) <> "") And Len(arr(i, 6)) = 9 Then
arr(i, 1) = ""
End If
Next i

Dim brr
ReDim brr(UBound(arr), 12)
k = 1
For i = 2 To UBound(brr)
If arr(i, 10) = arr(i, 13) And InStr(arr(i, 7), "tbn") + InStr(arr(i, 7), "TBN") = 0 And arr(i, 1) <> "" And CDate(arr(i, 15)) < CDate(Evaluate("=TODAY()")) And DateAdd("m", -5, CDate(Evaluate("=TODAY()"))) < CDate(arr(i, 15)) _
And arr(i, 13) <> "CNAQG" _
And arr(i, 13) <> "CNCGU" _
And arr(i, 13) <> "CNCZ1" _
And arr(i, 13) <> "CNCZX" _
And arr(i, 13) <> "CNDFE" _
And arr(i, 13) <> "CNHFE" _
And arr(i, 13) <> "CNJIA" _
And arr(i, 13) <> "CNMAA" _
And arr(i, 13) <> "CNNKG" _
And arr(i, 13) <> "CNNTG" _
And arr(i, 13) <> "CNRUG" _
And arr(i, 13) <> "CNTOL" _
And arr(i, 13) <> "CNTZO" _
And arr(i, 13) <> "CNWHI" _
And arr(i, 13) <> "CNYZH" _
And arr(i, 13) <> "CNZHE" _
And arr(i, 13) <> "CNZJG" _
And arr(i, 13) <> "CNLZU" _
And arr(i, 13) <> "CNCKG" _
And arr(i, 13) <> "CNWUH" _
And arr(i, 13) <> "CNCLJ" _
And arr(i, 13) <> "CNJIU" And arr(i, 13) <> "CNCDE" And arr(i, 13) <> "CNJGZ" And arr(i, 13) <> "CNQZH" And arr(i, 13) <> "CNSHA" _
And arr(i, 13) <> "CNTAG" And arr(i, 13) <> "CNYBN" And arr(i, 13) <> "CNCSX" And arr(i, 13) <> "CNHSI" And arr(i, 13) <> "CNYUY" And arr(i, 13) <> "CNKHN" And arr(i, 13) <> "CNCTU" And arr(i, 13) <> "CNYIC" _
Then
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 6)
brr(k, 4) = arr(i, 7)
brr(k, 5) = arr(i, 8)
brr(k, 6) = arr(i, 9)
brr(k, 7) = arr(i, 13)
brr(k, 8) = arr(i, 14)
brr(k, 9) = arr(i, 15)
brr(k, 10) = arr(i, 12)




If dic2.exists(arr(i, 1) & arr(i, 10)) Then

brr(k, 12) = dic2(arr(i, 1) & arr(i, 10))

ElseIf dic3.exists(arr(i, 10)) And brr(k, 12) = "" Then

brr(k, 12) = dic3(arr(i, 10))

End If




If dic.exists(arr(i, 2)) Then

brr(k, 11) = dic(arr(i, 2))

ElseIf dic1.exists(arr(i, 2)) Then

brr(k, 11) = dic1(arr(i, 2))

End If




k = k + 1
End If

Next i



Sheets.Add
ActiveSheet.Name = "Status 20"
Sheets.Add
ActiveSheet.Name = "Pre-Discharge"
Sheets.Add
ActiveSheet.Name = "ICC"


Sheets("Status 20").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")
Sheets("Pre-Discharge").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")
Sheets("ICC").Range("a1:m1") = Array("Service", "BL", "Import Voyage", "Vessle", "Status", "POL", "POD", "FPOD", "ETA", "DP_Code", "PIC", "Comments", "History")


k = 2
l = 2
m = 2

For i = 2 To UBound(brr)

If brr(i, 5) = 20 Then

Sheets("Status 20").Cells(k, 1) = brr(i, 1)
Sheets("Status 20").Cells(k, 2) = brr(i, 2)
Sheets("Status 20").Cells(k, 3) = brr(i, 3)
Sheets("Status 20").Cells(k, 4) = brr(i, 4)
Sheets("Status 20").Cells(k, 5) = brr(i, 5)
Sheets("Status 20").Cells(k, 6) = brr(i, 6)
Sheets("Status 20").Cells(k, 7) = brr(i, 7)
Sheets("Status 20").Cells(k, 8) = brr(i, 8)
Sheets("Status 20").Cells(k, 9) = brr(i, 9)
Sheets("Status 20").Cells(k, 10) = brr(i, 10)
Sheets("Status 20").Cells(k, 13) = brr(i, 11)
Sheets("Status 20").Cells(k, 11) = brr(i, 12)

k = k + 1

ElseIf brr(i, 5) = 30 Then

Sheets("Pre-Discharge").Cells(l, 1) = brr(i, 1)
Sheets("Pre-Discharge").Cells(l, 2) = brr(i, 2)
Sheets("Pre-Discharge").Cells(l, 3) = brr(i, 3)
Sheets("Pre-Discharge").Cells(l, 4) = brr(i, 4)
Sheets("Pre-Discharge").Cells(l, 5) = brr(i, 5)
Sheets("Pre-Discharge").Cells(l, 6) = brr(i, 6)
Sheets("Pre-Discharge").Cells(l, 7) = brr(i, 7)
Sheets("Pre-Discharge").Cells(l, 8) = brr(i, 8)
Sheets("Pre-Discharge").Cells(l, 9) = brr(i, 9)
Sheets("Pre-Discharge").Cells(l, 10) = brr(i, 10)
Sheets("Pre-Discharge").Cells(l, 13) = brr(i, 11)
Sheets("Pre-Discharge").Cells(l, 11) = brr(i, 12)

l = l + 1

ElseIf brr(i, 5) = 60 Then

Sheets("ICC").Cells(m, 1) = brr(i, 1)
Sheets("ICC").Cells(m, 2) = brr(i, 2)
Sheets("ICC").Cells(m, 3) = brr(i, 3)
Sheets("ICC").Cells(m, 4) = brr(i, 4)
Sheets("ICC").Cells(m, 5) = brr(i, 5)
Sheets("ICC").Cells(m, 6) = brr(i, 6)
Sheets("ICC").Cells(m, 7) = brr(i, 7)
Sheets("ICC").Cells(m, 8) = brr(i, 8)
Sheets("ICC").Cells(m, 9) = brr(i, 9)
Sheets("ICC").Cells(m, 10) = brr(i, 10)
Sheets("ICC").Cells(m, 13) = brr(i, 11)
Sheets("ICC").Cells(m, 11) = brr(i, 12)


m = m + 1


End If

Next i

Sheets("ICC").Cells.EntireColumn.AutoFit
Sheets("Pre-Discharge").Cells.EntireColumn.AutoFit
Sheets("Status 20").Cells.EntireColumn.AutoFit

MsgBox "Done"

End Sub

3.9 NC_Manifest

Sub SHmanifest()

Dim MyBook1, MyBook2 As Workbook

Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
     .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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)

Set MyBook2 = Workbooks.Open(ipath)

MyBook2.Sheets(1).Copy MyBook1.Sheets(1)
MyBook2.Close

Dim arr, arr1, arr2

Sheets(2).Select

Sheets(2).[a5].Resize(Sheets(2).Cells(Sheets(2).Rows.Count, 1).End(xlUp).ROW - 5, Sheets(2).Cells(5, Sheets(2).Columns.Count).End(xlToLeft).Column).Select

arr = Selection

Dim dic1, dic2
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")


For j = 1 To UBound(arr)

If Left(arr(j, 1), 3) <> "EXT" _
And Left(arr(j, 11), 2) <> "CN" _
And arr(j, 7) <> "M" _
And arr(j, 10) <> "E E" _
And InStr(arr(j, 9), "CMA CGM") + InStr(arr(j, 9), "ANL CHINA LIMITED") + InStr(arr(j, 9), "CMA SHIPS") + InStr(arr(j, 9), "CMA-CGM") < 1 _
Then

dic1(arr(j, 5)) = arr(j, 2) & "/" & arr(j, 15)

End If


Next j

arr1 = dic1.Keys
arr2 = dic1.Items

Dim brr, brr1, brr2

Sheets(1).Select

Sheets(1).[a2].Resize(Sheets(1).Cells(Sheets(1).Rows.Count, 1).End(xlUp).ROW - 1, Sheets(1).Cells(5, Sheets(1).Columns.Count).End(xlToLeft).Column).Select

brr = Selection

For j = 1 To UBound(brr)

If dic2(brr(j, 5)) = "" Then

dic2(brr(j, 5)) = brr(j, 7) & "/" & brr(j, 1)

ElseIf dic2(brr(j, 5)) <> brr(j, 7) & "/" & brr(j, 1) Then

dic2(brr(j, 5)) = dic2(brr(j, 5)) & "/" & brr(j, 7) & "/" & brr(j, 1)

End If


Next j

brr1 = dic2.Keys
brr2 = dic2.Items

For j = 0 To UBound(arr1) - 1

If dic2.exists(arr1(j)) And InStr(dic2(arr1(j)), dic1(arr1(j))) >= 1 Then

dic1.Remove arr1(j)

End If

Next j


arr = dic1.Keys


For j = 0 To UBound(arr)

Sheets(2).Range("e:e").Find(arr(j)).Interior.Color = 10217471

Next j

dic2.RemoveAll
dic1.RemoveAll

Sheets(2).Select
Sheets(2).[e4].AutoFilter
Sheets(2).Cells.AutoFilter Field:=5, Criteria1:=RGB(255, 231, 155), Operator:=xlFilterCellColor

Sheets(1).Name = "Inbound List"
Sheets(2).Name = "C-report"
MsgBox "Done"



End Sub


Sub SHmani()

Dim MyBook1, MyBook2 As Workbook

Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
     .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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)

Set MyBook2 = Workbooks.Open(ipath)

MyBook2.Sheets(1).Copy MyBook1.Sheets(1)
MyBook2.Close
MyBook1.Sheets(1).Name = "Inbound List"
MyBook1.Sheets(2).Name = "C-report"


Dim dic1, dic2
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")

For i = 2 To Sheets("Inbound List").Cells(Rows.Count, 1).End(xlUp).ROW

Sheets("Inbound List").Cells(i, "AV").Value = Sheets("Inbound List").Cells(i, "F").Value & Sheets("Inbound List").Cells(i, "A").Value


If dic1(Sheets("Inbound List").Cells(i, "E").Value) = "" Then

dic1(Sheets("Inbound List").Cells(i, "E").Value) = Sheets("Inbound List").Cells(i, "F").Value & Sheets("Inbound List").Cells(i, "A").Value


ElseIf dic1(Sheets("Inbound List").Cells(i, "E").Value) <> Sheets("Inbound List").Cells(i, "F").Value & Sheets("Inbound List").Cells(i, "A").Value Then

dic1(Sheets("Inbound List").Cells(i, "E").Value) = dic1(Sheets("Inbound List").Cells(i, "E").Value) & Sheets("Inbound List").Cells(i, "F").Value & Sheets("Inbound List").Cells(i, "A").Value

End If


Next i




For j = 5 To Sheets("C-report").Cells(Rows.Count, 1).End(xlUp).ROW


Sheets("C-report").Cells(j, "t") = Sheets("C-report").Cells(j, "d") & Sheets("C-report").Cells(j, "o")

If dic2(Sheets("C-report").Cells(j, "f").Value) = "" Then

dic2(Sheets("C-report").Cells(j, "f").Value) = Sheets("C-report").Cells(j, "d").Value & Sheets("C-report").Cells(j, "o").Value


ElseIf dic2(Sheets("C-report").Cells(j, "f").Value) <> Sheets("C-report").Cells(j, "d").Value & Sheets("C-report").Cells(j, "o").Value Then

dic2(Sheets("C-report").Cells(j, "f").Value) = dic2(Sheets("C-report").Cells(j, "f").Value) & Sheets("C-report").Cells(j, "d").Value & Sheets("C-report").Cells(j, "o").Value

End If


Next j


For i = 2 To Sheets("Inbound List").Cells(Rows.Count, 1).End(xlUp).ROW

If IsError(Application.VLookup(Sheets("Inbound List").Cells(i, "e"), Sheets("C-report").Range("f:f"), 1, False)) _
And Sheets("Inbound List").Cells(i, "P") <> "" _
Then

Sheets("Inbound List").Cells(i, "e").Interior.ColorIndex = 36


ElseIf Not IsError(Application.VLookup(Sheets("Inbound List").Cells(i, "e"), Sheets("C-report").Range("f:f"), 1, False)) _
And InStr(dic2(Sheets("Inbound List").Cells(i, "e").Value), Sheets("Inbound List").Cells(i, "av").Value) < 1 _
Then

Sheets("Inbound List").Cells(i, "e").Interior.ColorIndex = 36

End If

Next i


For j = 5 To Sheets("C-report").Cells(Rows.Count, 1).End(xlUp).ROW

If IsError(Application.VLookup(Sheets("C-report").Cells(j, "f"), Sheets("Inbound List").Range("e:e"), 1, False)) _
And Left(Sheets("C-report").Cells(j, "a"), 3) <> "EXT" _
And Left(Sheets("C-report").Cells(j, "k"), 2) <> "CN" _
And Sheets("C-report").Cells(j, "G") <> "M" _
And Sheets("C-report").Cells(j, "F") <> "" _
And Sheets("C-report").Cells(j, "J") <> "E E" _
And InStr(Sheets("C-report").Cells(j, "i"), "CMA CGM") + InStr(Sheets("C-report").Cells(j, "i"), "ANL CHINA LIMITED") + InStr(Sheets("C-report").Cells(j, "i"), "CMA SHIPS") + InStr(Sheets("C-report").Cells(j, "i"), "CMA-CGM") < 1 _
Then

Sheets("C-report").Cells(j, "f").Interior.ColorIndex = 36

ElseIf Not IsError(Application.VLookup(Sheets("C-report").Cells(j, "f"), Sheets("Inbound List").Range("e:e"), 1, False)) _
And InStr(dic1(Sheets("C-report").Cells(j, "F").Value), Sheets("C-report").Cells(j, "t").Value) < 1 _
And Left(Sheets("C-report").Cells(j, "a"), 3) <> "EXT" _
And Left(Sheets("C-report").Cells(j, "k"), 2) <> "CN" _
And Sheets("C-report").Cells(j, "G") <> "M" _
And Sheets("C-report").Cells(j, "F") <> "" _
And Sheets("C-report").Cells(j, "J") <> "E E" _
And InStr(Sheets("C-report").Cells(j, "i"), "CMA CGM") + InStr(Sheets("C-report").Cells(j, "i"), "ANL CHINA LIMITED") + InStr(Sheets("C-report").Cells(j, "i"), "CMA SHIPS") + InStr(Sheets("C-report").Cells(j, "i"), "CMA-CGM") < 1 _
Then

Sheets("C-report").Cells(j, "f").Interior.ColorIndex = 36

End If

Next j

Sheets("Inbound List").[e1].AutoFilter
Sheets("Inbound List").Cells.AutoFilter Field:=5, Criteria1:=RGB(255, 255, 153), Operator:=xlFilterCellColor
    
    
Sheets("C-report").[F4].AutoFilter
Sheets("C-report").Cells.AutoFilter Field:=6, Criteria1:=RGB(255, 255, 153), Operator:=xlFilterCellColor

MsgBox "Done"

End Sub

3.10 NC_Find_PIC

Sub find_pic2()

Dim con As New Connection
Dim conn As New Connection
Dim connn As New Connection

con.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "\\CNGSCAPL-SPF303\Customer_Care\Doc_Import\Share\CN_Import\02SHA\07 Tools\00 Database\NCIMPWSNGB.accdb"
conn.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "\\CNGSCAPL-SPF303\Customer_Care\Doc_Import\Share\CN_Import\02SHA\07 Tools\00 Database\NCIMPWSNC.accdb"
connn.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "C:\Users\GSC.BFU\Desktop\bOB\Database_Bob.accdb"


Dim sql, sqll As String

sql = "select PIC,EVOY & POD as IMvoyagePort from Vessels"
sqll = "select * from Pre_Discharge_PIC"

Set rs = con.Execute(sql)
Set rs1 = conn.Execute(sql)
Set rs2 = connn.Execute(sqll)


On Error Resume Next

Dim imvoyageport, svport, port

For i = 2 To Cells(Rows.Count, 1).End(xlUp).ROW

imvoyageport = Cells(i, 3) & Cells(i, 7)
svport = Cells(i, 1) & Cells(i, 7)
port = Cells(i, 7)

If Cells(i, 11) = "" Then

rs2.Find "SVR_PORT= '" & svport & "'", , , 1

Cells(i, 11) = rs1.Fields(3)

End If


If Cells(i, 11) = "" Then

rs2.Find "Port= '" & port & "'", , , 1

Cells(i, 11) = rs2.Fields(1)

End If


If Cells(i, 11) = "" Then

rs.Find "IMvoyagePort= '" & imvoyageport & "'", , , 1

Cells(i, 11) = rs.Fields(0)

End If


If Cells(i, 11) = "" Then

rs1.Find "IMvoyagePort= '" & imvoyageport & "'", , , 1

Cells(i, 11) = rs.Fields(0)

End If

Next i

On Error GoTo 0

rs.Close
rs1.Close
rs2.Close
con.Close
conn.Close
connn.Close
Set rs = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
Set con = Nothing
Set conn = Nothing
Set conn = Nothing

End Sub

3.11 NC_EmailCHECK

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

3.12 NC_DPcode

Sub DPcode()


arr = Selection
brr = Split(Selection.Address, "$")

lie = Range(brr(1) & 1).Column
hang = Split(brr(2), ":")(0)


Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("ADODB.recordset")

conn.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "\\Cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\Database_Bob.accdb"
 

rst.Open "select *,Ship_Angecy.Port & Ship_Angecy.Voyage as PV from Department_Code left join Ship_Angecy on Department_Code.Port = Ship_Angecy.Port", conn, adOpenKeyset, adLockOptimistic

crr = rst.GetRows

Dim port, PV


For i = 1 To UBound(arr)


port = arr(i, 2)

rst.Find "Department_Code.Port= '" & port & "'", , , 1

If (Len(arr(i, 1)) > 6 And Right(arr(i, 1), 2) = "MA") Or Len(arr(i, 1)) <= 6 Then

Cells(Split(brr(2), ":")(0) + j, Range(brr(1) & 1).Column + 2) = rst.Fields(3)

ElseIf Len(arr(i, 1)) > 6 And Right(arr(i, 1), 2) = "NL" Then

Cells(Split(brr(2), ":")(0) + j, Range(brr(1) & 1).Column + 2) = rst.Fields(4)

ElseIf Len(arr(i, 1)) > 6 And Right(arr(i, 1), 2) = "NC" Then

Cells(Split(brr(2), ":")(0) + j, Range(brr(1) & 1).Column + 2) = rst.Fields(5)

End If


'jiaru huodai

On Error Resume Next

PV = arr(i, 2) & Left(arr(i, 1), 3)

rst.Find "PV= '" & PV & "'", , , 1


If Len(arr(i, 1)) > 6 Then

Cells(Split(brr(2), ":")(0) + j, Range(brr(1) & 1).Column + 3) = rst.Fields(9)

Cells(Split(brr(2), ":")(0) + j, Range(brr(1) & 1).Column + 4) = rst.Fields(10)

End If

On Error GoTo 0


j = j + 1

Next i


End Sub

3.13 BayPlanCheck()

Sub BayPlanCheck()

arr = Selection

Dim MyBook1, MyBook2 As Workbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\TXT"
    .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)

Set MyBook1 = Workbooks.Open(ipath)

brr = MyBook1.Sheets(1).[b4].Resize(Cells(Rows.Count, 1).End(xlUp).ROW - 14, 2)
crr = MyBook1.Sheets(1).[a1]

MyBook1.Close

Dim dic, dic1, dic2, dic3
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")

'船图字典

For i = 1 To UBound(arr)

dic(arr(i, 1)) = 0

Next i


'舱单字典

For i = 1 To UBound(brr)

If brr(i, 1) = "" Then

brr(i, 1) = brr(i - 1, 1)

End If

dic1(brr(i, 2)) = brr(i, 1)

Next i




'舱单无

For i = 1 To UBound(arr)

If Not dic1.exists(arr(i, 1)) Then

dic2(arr(i, 1)) = 0

End If

Next i




'船图无

For i = 1 To UBound(brr)

If Not dic.exists(brr(i, 2)) Then

dic3(brr(i, 2)) = brr(i, 1)

End If

Next i

Workbooks.Add

Set MyBook2 = ActiveWorkbook

MyBook2.Sheets(1).Name = "BayPlan Check Result"

MyBook2.Sheets(1).Range("a1:d1") = Array("舱单无_Container", "舱单无_BL", "船图无_Container", "船图无_BL")
MyBook2.Sheets(1).Range("f1") = crr

If dic2.Count <> 0 Then
Range("a2").Resize(dic2.Count) = Application.Transpose(dic2.Keys)

End If

If dic3.Count <> 0 Then
Range("c2").Resize(dic3.Count) = Application.Transpose(dic3.Keys)
Range("d2").Resize(dic3.Count) = Application.Transpose(dic3.Items)

End If

Cells.EntireColumn.AutoFit
Range("a1:f1").Interior.ColorIndex = 36


MsgBox "Done"


End Sub

3.14 NC_ANcomments

Sub NCcomments()


Dim MyBook1, MyBook2 As Workbook
Set MyBook1 = ActiveWorkbook

Workbooks.Open ("\\Cngscapl-spf302\IB\AM Team\01 IB - LARA\15 Personal Folder\NCCC AN Pending.xlsx")
Set MyBook2 = ActiveWorkbook

For i = 1 To MyBook2.Worksheets.Count
MyBook2.Sheets(i).Copy MyBook1.Sheets(1)
Next i
MyBook2.Close

'删除不需要的

For x = 2 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).ROW

If Weekday(Date, 2) = 5 Then

If (Sheets("Sheet1").Cells(x, "f") = "E E" And Sheets("Sheet1").Cells(x, "g") = "M") _
Or Sheets("Sheet1").Cells(x, "D") = "TBN11" _
Or Sheets("Sheet1").Cells(x, "e") = "1" _
Or (Sheets("Sheet1").Cells(x, "C") = "" And Sheets("Sheet1").Cells(x, "B") <> "") _
Or Sheets("Sheet1").Cells(x, "M") >= Date + 5 _
Or (Sheets("Sheet1").Cells(x, "j") = "CNTAG" And Sheets("Sheet1").Cells(x, "L") <> "KRPUS") Then
Sheets("Sheet1").Rows(x).Delete
x = x - 1
End If

ElseIf Weekday(Date, 2) <> 5 Then

If (Sheets("Sheet1").Cells(x, "f") = "E E" And Sheets("Sheet1").Cells(x, "g") = "M") _
Or Sheets("Sheet1").Cells(x, "D") = "TBN11" _
Or Sheets("Sheet1").Cells(x, "e") = "1" _
Or (Sheets("Sheet1").Cells(x, "C") = "" And Sheets("Sheet1").Cells(x, "B") <> "") _
Or Sheets("Sheet1").Cells(x, "M") >= Date + 3 _
Or (Sheets("Sheet1").Cells(x, "j") = "CNTAG" And Sheets("Sheet1").Cells(x, "L") <> "KRPUS") Then
Sheets("Sheet1").Rows(x).Delete
x = x - 1
End If

End If

Next x


'连接PIC数据库
'Dim conn,con As New Connection
'Dim sql,sqll As String
'Dim rs, rs1 As New ADODB.Recordset
'conn.Open "provider=Microsoft.ace.OLEDB.12.0;data source=" & "C:\Users\GSC.BFU\Desktop\VBA1\数据库\New Microsoft Access Database - Copy.accdb"
'sql = "select * from WK42"
'Set rs = conn.Execute(sql)

Dim con As New Connection
con.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & "\\Cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\NC Comments Auto\SH AN PIC.xlsx"

Dim sql As String
sql = "select DischargeVoyage & PointTo as VoyagePort,PIC from [Sheet1$]"

Set rstt = con.Execute(sql)


'连接CODE数据库
'con.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & "\\Cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\SHA Email Ask Atuo\DP Code.xlsx"
'sqll = "select * from WK42"
'Set rs1 = con.Execute(sqll)


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=" & "\\Cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\SHA Email Ask Atuo\DP Code.xlsx"
rst.Open "select *  from [Sheet1$]", conn, adOpenKeyset, adLockOptimistic


'加入pic,code,comments

Dim VoyagePort
On Error Resume Next
For x = 2 To Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).ROW

'PIC

VoyagePort = Sheets("Sheet1").Cells(x, 3) & Sheets("Sheet1").Cells(x, 10)

rstt.Find "VoyagePort= '" & VoyagePort & "'", , , 1

Sheets("Sheet1").Cells(x, 16) = rstt.Fields(1)


'Code

If Len(Sheets("Sheet1").Cells(x, "c")) > 6 Then

Sheets("Sheet1").Cells(x, "o") = rst.Fields(Sheets("Sheet1").Cells(x, "j") & Right(Sheets("Sheet1").Cells(x, "c").Value, 2))

If Sheets("Sheet1").Cells(x, "o") = "" Then

Sheets("Sheet1").Cells(x, "o") = rst.Fields(Sheets("Sheet1").Cells(x, "l") & Right(Sheets("Sheet1").Cells(x, "c").Value, 2))

End If

Else

Sheets("Sheet1").Cells(x, "o") = rst.Fields(Sheets("Sheet1").Cells(x, "j") & "MA")

If Sheets("Sheet1").Cells(x, "o") = "" Then

Sheets("Sheet1").Cells(x, "o") = rst.Fields(Sheets("Sheet1").Cells(x, "l") & "MA")

End If

End If

'FEEDER

If Sheets("Sheet1").Cells(x, "L") = "CNTAO" Then
Sheets("Sheet1").Cells(x, "Q").Interior.ColorIndex = 36
End If



'Comments

For Y = 1 To Worksheets.Count - 1

Sheets("Sheet1").Cells(x, "Q") = Sheets(Y).Range("A:A").Find(Sheets("Sheet1").Cells(x, "B")).Offset(0, 6).Value

Next Y



Next x


On Error GoTo 0

Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Comments"
Range("o1:q1") = Array("Code", "PIC", "Comments")
Cells.EntireColumn.AutoFit
MsgBox "done"

End Sub

3.15 AM_UndeliverableCheck

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

3.16 AM_EmailCheck

Sub emailck()

Application.DisplayAlerts = False
Dim i As Integer, j, k, z, w As Integer
Dim rnga, rngb, rngc, rngd As Range
On Error Resume Next

Worksheets.Add After:=Sheets(1)
Worksheets(2).Name = "focus BLs"

If Worksheets.Count > 2 Then

Sheets(2).Delete

End If


Worksheets(1).Activate

Columns("d").Hidden = True







Range("a16:n16").Copy Sheets(2).[a1]


For i = 1 To ActiveSheet.UsedRange.Rows.Count Step 1

If Range("M" & i) = "NO" And (Range("M" & i + 1) = "YES" Or Range("M" & i + 1) = "") Then

Range("m" & i).Select
j = i

End If


Next i

For k = 17 To j Step 1

If Range("b" & k) = Range("b" & k + 1) And Range("b" & k) = Range("b" & k + 2) Then

Range("b" & k).Interior.Color = vbRed
Range("b" & k + 1).Interior.Color = vbRed
Range("b" & k + 2).Interior.Color = vbRed








    Else
    If Range("b" & k) = Range("b" & k + 1) And Range("b" & k - 1) <> Range("b" & k) Then

          If Range("J" & k) <> "NO2" And Range("J" & k + 1) <> "NO2" Then

          Range("b" & k).Interior.Color = vbRed
          Range("b" & k + 1).Interior.Color = vbRed
          
          End If

    End If

End If


Next k




Dim f, n As Integer


For n = 17 To ActiveSheet.UsedRange.Rows.Count Step 1

Select Case Range("b" & n).Interior.Color

Case vbRed
f = f + 1

End Select

Next n


MsgBox "done"

w = 2

For z = 17 To ActiveSheet.UsedRange.Rows.Count Step 1

If Range("b" & z).Interior.Color = vbRed Then

Rows(z).Copy Sheets(2).Range("a" & w)

w = w + 1

End If

Next z


Dim h, m As Integer
For h = 2 To Sheets(2).UsedRange.Rows.Count Step 1
If Sheets(2).Range("b" & h) = Sheets(2).Range("b" & h + 1) And (Sheets(2).Range("n" & h) = "" And Sheets(2).Range("n" & h + 1) = "") Then

Sheets(2).Rows(h + 1).Delete
 Else
 If Sheets(2).Range("b" & h) = Sheets(2).Range("b" & h + 1) And (Sheets(2).Range("n" & h) <> "" And Sheets(2).Range("n" & h + 1) = "") Then
 Sheets(2).Rows(h + 1).Delete
 Else
 If Sheets(2).Range("b" & h) = Sheets(2).Range("b" & h + 1) And (Sheets(2).Range("n" & h) = "" And Sheets(2).Range("n" & h + 1) <> "") Then
 Sheets(2).Rows(h).Delete
 
 End If
 
 End If
 

End If

Next h

Sheets(1).Range("b17:b5000").Interior.ColorIndex = xlNone


Sheets(2).Activate

Cells.Select
Cells.EntireColumn.AutoFit




Application.DisplayAlerts = True


End Sub

3.17 AM_ScheduPHI

Sub SchePHI()

'fuzhi xuyao biaoge
Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "\\cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB"
    .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 MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook2 = Workbooks.Open(ipath)
MyBook2.Sheets("Page1_1").Copy MyBook1.Sheets("page")
MyBook2.Close
MyBook1.Sheets("Page1_1").Name = "Schedule Report"

Workbooks.Open ("\\cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\PHI Schedule Atuo\PHI Schedule History.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("page")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Schedule History"

Workbooks.Open ("\\cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\PHI Schedule Atuo\PHI PIC.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("page")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "PIC"

' quchong
Sheets.Add
Sheets("sheet4").Name = "working"
Sheets("page").Range("A:A,C:C,I:I,L:L").Copy Sheets("working").[a1]
Sheets("working").Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4) _
        , Header:=xlYes
        

'tiqu chuangtizhi


Dim EJ As Date


EJ = ScheuD.TextBox2.Value

'SHUJUZHENGLI

For X1 = 1 To Sheets("Schedule History").Range("a65536").End(xlUp).ROW + 50

Sheets("Schedule History").Cells(X1, "m").Value = Sheets("Schedule History").Cells(X1, "B").Value & Sheets("Schedule History").Cells(X1, "C").Value

Next X1


For X3 = 1 To Sheets("PIC").Range("a65536").End(xlUp).ROW

Sheets("PIC").Cells(X3, "D") = Sheets("PIC").Cells(X3, "B") & "/" & Sheets("PIC").Cells(X3, "C")

Next X3


For X5 = 1 To Sheets("Schedule Report").Range("a65536").End(xlUp).ROW

Sheets("Schedule Report").Cells(X5, "X") = Sheets("Schedule Report").Cells(X5, "J") & Sheets("Schedule Report").Cells(X5, "H")

Next X5


'sainchu PA,ETA,ZUOGUODECHUAN

Dim ROW As Integer

Dim SCH()

ROW = Sheets("working").Range("a65536").End(xlUp).ROW

ReDim SCH(1 To ROW, 1 To 13)

For X2 = 2 To ROW

If "PH" = Left(Sheets("working").Cells(X2, "d"), 2) _
And Sheets("working").Cells(X2, "c") <= EJ _
And IsError(Application.VLookup(Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d"), Sheets("Schedule History").Range("M:M"), 1, False)) Then

SCH(X2, 1) = Left(Sheets("working").Cells(X2, "a"), 3)
SCH(X2, 2) = Sheets("working").Cells(X2, "b")
SCH(X2, 3) = Sheets("working").Cells(X2, "c")
SCH(X2, 4) = Sheets("working").Cells(X2, "d")
SCH(X2, 10) = Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d")

'chaxun schedule LAST FOREIGHT PORT & EXPORT VOYAGE

On Error Resume Next
'LAST port etd
SCH(X2, 6) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -9)
SCH(X2, 7) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -7)

SCH(X2, 11) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -5)
SCH(X2, 12) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -3)
On Error GoTo 0

'chaxun pic

SCH(X2, 8) = Application.VLookup(SCH(X2, 1), Sheets("PIC").Range("A:D"), 4, False)

End If

Next X2


'shuchu



   Sheets.Add
   ActiveSheet.Name = "Schedulewk"

Sheets("Schedulewk").[a1] = "Regin"
Sheets("Schedulewk").[a2] = "PHI"
Sheets("Schedulewk").[b1] = "GSC PIC"
Sheets("Schedulewk").[c1] = "Service"
Sheets("Schedulewk").[d1] = "Import Voyage"
Sheets("Schedulewk").[e1] = "POD"
Sheets("Schedulewk").[F1] = "ETD"
Sheets("Schedulewk").[G1] = "ETA"
Sheets("Schedulewk").[H1] = "Conmments"

'qukong

Dim SCH1()

ReDim SCH1(1 To ROW, 1 To 9)

For X2 = 2 To ROW

If SCH(X2, 1) <> "" Then

SCH1((k + 1), 1) = SCH(X2, 1)
SCH1((k + 1), 2) = SCH(X2, 2)
SCH1((k + 1), 3) = SCH(X2, 3)
SCH1((k + 1), 4) = SCH(X2, 4)
SCH1((k + 1), 5) = SCH(X2, 5)
SCH1((k + 1), 8) = SCH(X2, 8)


If Left(SCH(X2, 6), 2) <> "PH" Then

SCH1((k + 1), 7) = SCH(X2, 7)

ElseIf Left(SCH(X2, 6), 2) = "PH" And Left(SCH(X2, 11), 2) <> "PH" Then

SCH1((k + 1), 7) = SCH(X2, 12)

ElseIf Left(SCH(X2, 6), 2) = "PH" And Left(SCH(X2, 11), 2) = "PH" Then

SCH1((k + 1), 7) = "not find"

End If


k = k + 1
        
    End If
    
Next X2


For X4 = 1 To ROW


Sheets("Schedulewk").Cells(X4 + 1, "b") = SCH1(X4, 8)
Sheets("Schedulewk").Cells(X4 + 1, "c") = Left(SCH1(X4, 1), 3)
Sheets("Schedulewk").Cells(X4 + 1, "D") = SCH1(X4, 2)
Sheets("Schedulewk").Cells(X4 + 1, "E") = SCH1(X4, 4)
Sheets("Schedulewk").Cells(X4 + 1, "F") = SCH1(X4, 7)
Sheets("Schedulewk").Cells(X4 + 1, "G") = SCH1(X4, 3)

Next X4

Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlYes
 Range("F:F,G:G").NumberFormat = "[$-en-US]d-mmm;@"
 
     Cells.EntireColumn.AutoFit
    
    MsgBox "Done"


End Sub

3.18 AM_Schedule

Sub ScheE()

' quchong
Sheets.Add
Sheets("sheet1").Name = "working"
Sheets("page").Range("A:A,C:C,I:I,L:L,M:M").Copy Sheets("working").[a1]
Sheets("working").Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5) _
        , Header:=xlYes

'fuzhi xuyao biaoge
Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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 MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook2 = Workbooks.Open(ipath)
MyBook2.Sheets("Page1_1").Copy MyBook1.Sheets("page")
MyBook2.Close
MyBook1.Sheets("Page1_1").Name = "ETD"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\LTAM Schedule Atuo\LTAM Schedule History.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("page")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Schedule"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\LTAM Schedule Atuo\LTAM PIC.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("page")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "PIC"

'tiqu chuangtizhi
'yifenhaogekai guojia

Dim EJ As Date


EJ = ScheuD.TextBox2.Value


'SHUJUZHENGLI


For X1 = 1 To Sheets("Schedule").Range("a65536").End(xlUp).ROW + 50

Sheets("Schedule").Cells(X1, "m").Value = Sheets("Schedule").Cells(X1, "d").Value & Sheets("Schedule").Cells(X1, "e").Value

Next X1


For X3 = 1 To Sheets("PIC").Range("a65536").End(xlUp).ROW

Sheets("PIC").Cells(X3, "D") = Sheets("PIC").Cells(X3, "B") & "/" & Sheets("PIC").Cells(X3, "C")

Next X3


For X5 = 1 To Sheets("ETD").Range("a65536").End(xlUp).ROW

Sheets("ETD").Cells(X5, "X") = Sheets("ETD").Cells(X5, "J") & Sheets("ETD").Cells(X5, "H")

Next X5


'sainchu PA,ETA,ZUOGUODECHUAN

Dim ROW As Integer
Dim SCH()

ROW = Sheets("working").Range("a65536").End(xlUp).ROW

ReDim SCH(1 To ROW, 1 To 13)

For X2 = 2 To ROW

If ("PA" = Left(Sheets("working").Cells(X2, "d"), 2) Or "PA" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "HN" = Left(Sheets("working").Cells(X2, "d"), 2) Or "HN" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "PE" = Left(Sheets("working").Cells(X2, "d"), 2) Or "PE" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "MX" = Left(Sheets("working").Cells(X2, "d"), 2) Or "MX" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "SV" = Left(Sheets("working").Cells(X2, "d"), 2) Or "SV" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "CR" = Left(Sheets("working").Cells(X2, "d"), 2) Or "CR" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "NI" = Left(Sheets("working").Cells(X2, "d"), 2) Or "NI" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "EC" = Left(Sheets("working").Cells(X2, "d"), 2) Or "EC" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "CL" = Left(Sheets("working").Cells(X2, "d"), 2) Or "CL" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "GT" = Left(Sheets("working").Cells(X2, "d"), 2) Or "GT" = Left(Sheets("working").Cells(X2, "e"), 2) _
Or "DO" = Left(Sheets("working").Cells(X2, "d"), 2) Or "DO" = Left(Sheets("working").Cells(X2, "e"), 2)) _
And Sheets("working").Cells(X2, "c") <= EJ And IsError(Application.VLookup(Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d"), Sheets("Schedule").Range("M:M"), 1, False)) Then

SCH(X2, 1) = Sheets("working").Cells(X2, "a")
SCH(X2, 2) = Sheets("working").Cells(X2, "b")
SCH(X2, 3) = Sheets("working").Cells(X2, "c")
SCH(X2, 4) = Sheets("working").Cells(X2, "d")
SCH(X2, 5) = Sheets("working").Cells(X2, "e")
SCH(X2, 10) = Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d")

'chaxun schedule LAST FOREIGHT PORT & EXPORT VOYAGE

On Error Resume Next
'LAST port etd
SCH(X2, 6) = Sheets("ETD").Range("X:X").Find(SCH(X2, 10)).Offset(0, -9)
SCH(X2, 7) = Sheets("ETD").Range("X:X").Find(SCH(X2, 10)).Offset(0, -7)

SCH(X2, 11) = Sheets("ETD").Range("X:X").Find(SCH(X2, 10)).Offset(0, -5)
SCH(X2, 12) = Sheets("ETD").Range("X:X").Find(SCH(X2, 10)).Offset(0, -3)
On Error GoTo 0

'regin

If Sheets("working").Cells(X2, "e") <> "" Then
SCH(X2, 9) = Left(Sheets("working").Cells(X2, "e"), 2)
ElseIf Sheets("working").Cells(X2, "e") = "" Then
SCH(X2, 9) = Left(Sheets("working").Cells(X2, "d"), 2)
End If

'chaxun pic

SCH(X2, 8) = Application.VLookup(SCH(X2, 9), Sheets("PIC").Range("A:D"), 4, False)

End If



Next X2




'shuchu






   Sheets.Add
   ActiveSheet.Name = "Schedulewk"

Sheets("Schedulewk").[a1] = "Regin"
Sheets("Schedulewk").[b1] = "GSC PIC"
Sheets("Schedulewk").[c1] = "Service"
Sheets("Schedulewk").[d1] = "Import Voyage"
Sheets("Schedulewk").[e1] = "POD"
Sheets("Schedulewk").[F1] = "FPOD"
Sheets("Schedulewk").[G1] = "ETD for LFP"
Sheets("Schedulewk").[H1] = "ETA"
Sheets("Schedulewk").[i1] = "Conmments"

'qukong
Dim SCH1()
ReDim SCH1(1 To ROW, 1 To 9)

For X2 = 2 To ROW

If SCH(X2, 1) <> "" Then

SCH1((k + 1), 1) = SCH(X2, 1)
SCH1((k + 1), 2) = SCH(X2, 2)
SCH1((k + 1), 3) = SCH(X2, 3)
SCH1((k + 1), 4) = SCH(X2, 4)
SCH1((k + 1), 5) = SCH(X2, 5)
SCH1((k + 1), 8) = SCH(X2, 8)
SCH1((k + 1), 9) = SCH(X2, 9)

If Left(SCH(X2, 6), 2) <> SCH(X2, 9) Then

SCH1((k + 1), 7) = SCH(X2, 7)

ElseIf Left(SCH(X2, 6), 2) = SCH(X2, 9) And Left(SCH(X2, 11), 2) <> SCH(X2, 9) Then

SCH1((k + 1), 7) = SCH(X2, 12)

ElseIf Left(SCH(X2, 6), 2) = SCH(X2, 9) And Left(SCH(X2, 11), 2) = SCH(X2, 9) Then

SCH1((k + 1), 7) = "not find"

End If


k = k + 1
        
    End If
    
Next X2



For X4 = 1 To ROW

Sheets("Schedulewk").Cells(X4 + 1, "a") = SCH1(X4, 9)
Sheets("Schedulewk").Cells(X4 + 1, "b") = SCH1(X4, 8)
Sheets("Schedulewk").Cells(X4 + 1, "c") = SCH1(X4, 1)
Sheets("Schedulewk").Cells(X4 + 1, "D") = SCH1(X4, 2)
Sheets("Schedulewk").Cells(X4 + 1, "E") = SCH1(X4, 4)
Sheets("Schedulewk").Cells(X4 + 1, "F") = SCH1(X4, 5)
Sheets("Schedulewk").Cells(X4 + 1, "G") = SCH1(X4, 7)
Sheets("Schedulewk").Cells(X4 + 1, "H") = SCH1(X4, 3)

Next X4

'geshizhengli





Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlYes
 Range("G:G,H:H").NumberFormat = "[$-en-US]d-mmm;@"
 
     Columns("A:A").Select
    ActiveWorkbook.Worksheets("Schedulewk").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Schedulewk").Sort.SortFields.Add2 Key:=Range("A1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Schedulewk").Sort
        .SetRange Range("A2:H100")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    
    For x6 = 2 To Sheets("Schedulewk").Range("a65536").End(xlUp).ROW
    
        If Sheets("Schedulewk").Cells(x6, "g") <> "not find" Then
    
    If Sheets("Schedulewk").Cells(x6, "h") - Sheets("Schedulewk").Cells(x6, "g") <= 2 Then
    
    
    Sheets("Schedulewk").Cells(x6, "i") = "Check ETD"
    
    End If
    
    Else
    
     Sheets("Schedulewk").Cells(x6, "i") = "Check ETD"
     
  End If

    
Next x6

    Cells.EntireColumn.AutoFit
    
    MsgBox "Done"

End Sub



Sub ScheUS1()



'fuzhi xuyao biaoge
Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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 MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook2 = Workbooks.Open(ipath)
MyBook2.Sheets("Page1_1").Copy MyBook1.Sheets("page")
MyBook2.Close
MyBook1.Sheets("Page1_1").Name = "Schedule Report"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\US Schedule Atuo\US Schedule History.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("page")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Schedule History"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\US Schedule Atuo\US PIC.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("page")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "PIC"

' quchong
Sheets.Add
Sheets("sheet4").Name = "working"
Sheets("page").Range("A:A,C:C,I:I,L:L").Copy Sheets("working").[a1]
Sheets("working").Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4) _
        , Header:=xlYes


'tiqu chuangtizhi
'yifenhaogekai guojia

Dim EJ As Date


EJ = ScheuD.TextBox2.Value


'SHUJUZHENGLI



For X3 = 1 To Sheets("PIC").Range("a65536").End(xlUp).ROW

Sheets("PIC").Cells(X3, "D") = Sheets("PIC").Cells(X3, "B") & "/" & Sheets("PIC").Cells(X3, "C")

Next X3



'sainchu PA,ETA,ZUOGUODECHUAN

Dim ROW As Integer
Dim SCH()
Dim dic
Set dic = CreateObject("scripting.dictionary")


ROW = Sheets("working").Range("a65536").End(xlUp).ROW

ReDim SCH(1 To ROW, 1 To 13)

For X2 = 2 To ROW

If ("US" = Left(Sheets("working").Cells(X2, "d"), 2) _
Or "GU" = Left(Sheets("working").Cells(X2, "d"), 2) _
Or "MP" = Left(Sheets("working").Cells(X2, "d"), 2) _
Or "PR" = Left(Sheets("working").Cells(X2, "d"), 2)) _
And Sheets("working").Cells(X2, "c") <= EJ _
And IsError(Application.VLookup(Sheets("working").Cells(X2, "b"), Sheets("Schedule History").Range("B:B"), 1, False)) Then

SCH(X2, 1) = Sheets("working").Cells(X2, "a")
SCH(X2, 2) = Sheets("working").Cells(X2, "b")

End If


If SCH(X2, 1) <> "" Then
dic(SCH(X2, 2)) = SCH(X2, 1)
End If

Next X2

'CHAXUN PORT

Sheets.Add
Sheets("sheet5").Name = "Schedulewk"

[a1] = "Service"
[b1] = "Import Voyag"

Sheets("Schedulewk").Range("B2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("Schedulewk").Range("A2").Resize(dic.Count) = Application.Transpose(dic.Items)

MsgBox "COPY TOOLS REPORT TO NEW SHEET"

End Sub


Sub ScheUS2()

ActiveSheet.Name = "Port"

'shaichu meiguo

Dim SCH()

ROW = Sheets("Port").Range("a65536").End(xlUp).ROW

ReDim SCH(1 To ROW, 1 To 3)


For X1 = 2 To Sheets("Port").Range("a65536").End(xlUp).ROW

If ("US" = Left(Sheets("Port").Cells(X1, "C"), 2) _
Or "GU" = Left(Sheets("Port").Cells(X1, "C"), 2) _
Or "MP" = Left(Sheets("Port").Cells(X1, "C"), 2) _
Or "PR" = Left(Sheets("Port").Cells(X1, "C"), 2)) Then

SCH(X1, 1) = Sheets("Port").Cells(X1, "A")

SCH(X1, 2) = Sheets("Port").Cells(X1, "B")

SCH(X1, 3) = Sheets("Port").Cells(X1, "c")

End If

Next X1

'SAICHU PORT
Dim dic
   
Set dic = CreateObject("scripting.dictionary")


For X2 = 2 To ROW


dic(SCH(X2, 2)) = ""


Next X2


For X3 = 2 To ROW

If dic(SCH(X3, 2)) = "" Then
dic(SCH(X3, 2)) = SCH(X3, 3)
ElseIf dic(SCH(X3, 2)) <> "" Then
dic(SCH(X3, 2)) = dic(SCH(X3, 2)) & "\" & SCH(X3, 3)
End If

Next X3


Sheets("Schedulewk").Range("c1").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("Schedulewk").Range("d1").Resize(dic.Count) = Application.Transpose(dic.Items)

'DINGYI DAO SHUZU

Dim SCH1()

ROW1 = Sheets("Schedulewk").Range("a65536").End(xlUp).ROW

ReDim SCH1(1 To ROW, 1 To 10)

For X4 = 2 To ROW1
SCH1(X4, 1) = Sheets("Schedulewk").Cells(X4, "c")
SCH1(X4, 2) = Sheets("Schedulewk").Cells(X4, "d")
SCH1(X4, 3) = Sheets("Schedulewk").Cells(X4, "c") & Left(Sheets("Schedulewk").Cells(X4, "d"), 5)
Next X4

For X5 = 1 To Sheets("Schedule Report").Range("a65536").End(xlUp).ROW

Sheets("Schedule Report").Cells(X5, "x") = Sheets("Schedule Report").Cells(X5, "j") & Sheets("Schedule Report").Cells(X5, "h")

Next X5

For x6 = 2 To ROW1
On Error Resume Next
SCH1(x6, 4) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -13)
SCH1(x6, 9) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -18)

SCH1(x6, 5) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -9)
SCH1(x6, 6) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -7)
SCH1(x6, 7) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -5)
SCH1(x6, 8) = Sheets("Schedule Report").Range("X:X").Find(SCH1(x6, 3)).Offset(0, -3)
On Error GoTo 0
Next x6



Sheets.Add
Sheets("sheet7").Name = "Schedule"


For x7 = 2 To ROW



Sheets("Schedule").Cells(x7, "a") = SCH1(x7, 9)
Sheets("Schedule").Cells(x7, "B") = SCH1(x7, 1)
Sheets("Schedule").Cells(x7, "C") = SCH1(x7, 2)
Sheets("Schedule").Cells(x7, "D") = SCH1(x7, 4)

If Left(SCH1(x7, 5), 2) <> "CA" And Left(SCH1(x7, 5), 2) <> "US" Then
Sheets("Schedule").Cells(x7, "E") = SCH1(x7, 5)
Sheets("Schedule").Cells(x7, "F") = SCH1(x7, 6)

ElseIf (Left(SCH1(x7, 5), 2) = "CA" Or Left(SCH1(x7, 5), 2) = "US") And Left(SCH1(x7, 7), 2) <> "CA" And Left(SCH1(x7, 7), 2) <> "US" Then
Sheets("Schedule").Cells(x7, "E") = SCH1(x7, 7)
Sheets("Schedule").Cells(x7, "F") = SCH1(x7, 8)

ElseIf (Left(SCH1(x7, 5), 2) = "CA" Or Left(SCH1(x7, 5), 2) = "US") And (Left(SCH1(x7, 7), 2) = "CA" Or Left(SCH1(x7, 7), 2) = "US") Then
Sheets("Schedule").Cells(x7, "E") = "NEED CHECK"
Sheets("Schedule").Cells(x7, "F") = "NEED CHECK"

End If

Next x7

Sheets("Schedule").[a1] = "SV"
Sheets("Schedule").[b1] = "VV"
Sheets("Schedule").[c1] = "POD"
Sheets("Schedule").[d1] = "ETA"
Sheets("Schedule").[e1] = "LFP"
Sheets("Schedule").[F1] = "ETD"



    Sheets("Schedule").Range("D:D,F:F").NumberFormat = "[$-en-US]d-mmm;@"
        Sheets("Schedule").Cells.EntireColumn.AutoFit
        
        MsgBox "Done"
    
End Sub


Sub ScheCA()

'fuzhi xuyao biaoge
Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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 MyBook2, MyBook3, MyBook4 As Workbook
Set MyBook2 = Workbooks.Open(ipath)
MyBook2.Sheets("Page1_1").Copy MyBook1.Sheets("page")
MyBook2.Close
MyBook1.Sheets("Page1_1").Name = "Schedule Report"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\CA Schedule Atuo\CA Schedule History.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("page")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Schedule History"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\CA Schedule Atuo\CA PIC.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("page")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "PIC"

' quchong
Sheets.Add
Sheets("sheet4").Name = "working"
Sheets("page").Range("A:A,C:C,I:I,L:L").Copy Sheets("working").[a1]
Sheets("working").Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4) _
        , Header:=xlYes
        

'tiqu chuangtizhi


Dim EJ As Date


EJ = ScheuD.TextBox2.Value

'SHUJUZHENGLI

For X1 = 1 To Sheets("Schedule History").Range("a65536").End(xlUp).ROW + 50

Sheets("Schedule History").Cells(X1, "m").Value = Sheets("Schedule History").Cells(X1, "B").Value & Sheets("Schedule History").Cells(X1, "C").Value

Next X1


For X3 = 1 To Sheets("PIC").Range("a65536").End(xlUp).ROW

Sheets("PIC").Cells(X3, "D") = Sheets("PIC").Cells(X3, "B") & "/" & Sheets("PIC").Cells(X3, "C")

Next X3


For X5 = 1 To Sheets("Schedule Report").Range("a65536").End(xlUp).ROW

Sheets("Schedule Report").Cells(X5, "X") = Sheets("Schedule Report").Cells(X5, "J") & Sheets("Schedule Report").Cells(X5, "H")

Next X5


'sainchu PA,ETA,ZUOGUODECHUAN

Dim ROW As Integer

Dim SCH()

ROW = Sheets("working").Range("a65536").End(xlUp).ROW

ReDim SCH(1 To ROW, 1 To 13)

For X2 = 2 To ROW

If "CA" = Left(Sheets("working").Cells(X2, "d"), 2) _
And Sheets("working").Cells(X2, "c") <= EJ _
And IsError(Application.VLookup(Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d"), Sheets("Schedule History").Range("M:M"), 1, False)) Then

SCH(X2, 1) = Sheets("working").Cells(X2, "a")
SCH(X2, 2) = Sheets("working").Cells(X2, "b")
SCH(X2, 3) = Sheets("working").Cells(X2, "c")
SCH(X2, 4) = Sheets("working").Cells(X2, "d")
SCH(X2, 10) = Sheets("working").Cells(X2, "b") & Sheets("working").Cells(X2, "d")

'chaxun schedule LAST FOREIGHT PORT & EXPORT VOYAGE

On Error Resume Next
'LAST port etd
SCH(X2, 6) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -9)
SCH(X2, 7) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -7)

SCH(X2, 11) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -5)
SCH(X2, 12) = Sheets("Schedule Report").Range("X:X").Find(SCH(X2, 10)).Offset(0, -3)
On Error GoTo 0

'chaxun pic

SCH(X2, 8) = Application.VLookup(SCH(X2, 1), Sheets("PIC").Range("A:D"), 4, False)

End If

Next X2


'shuchu



   Sheets.Add
   ActiveSheet.Name = "Schedulewk"

Sheets("Schedulewk").[a1] = "Regin"
Sheets("Schedulewk").[a2] = "CAN"
Sheets("Schedulewk").[b1] = "GSC PIC"
Sheets("Schedulewk").[c1] = "Service"
Sheets("Schedulewk").[d1] = "Import Voyage"
Sheets("Schedulewk").[e1] = "POD"
Sheets("Schedulewk").[F1] = "ETD"
Sheets("Schedulewk").[G1] = "ETA"
Sheets("Schedulewk").[H1] = "Conmments"

'qukong

Dim SCH1()

ReDim SCH1(1 To ROW, 1 To 9)

For X2 = 2 To ROW

If SCH(X2, 1) <> "" Then

SCH1((k + 1), 1) = SCH(X2, 1)
SCH1((k + 1), 2) = SCH(X2, 2)
SCH1((k + 1), 3) = SCH(X2, 3)
SCH1((k + 1), 4) = SCH(X2, 4)
SCH1((k + 1), 5) = SCH(X2, 5)
SCH1((k + 1), 8) = SCH(X2, 8)


If Left(SCH(X2, 6), 2) <> "US" Then

SCH1((k + 1), 7) = SCH(X2, 7)

ElseIf Left(SCH(X2, 6), 2) = "US" And Left(SCH(X2, 11), 2) <> "US" Then

SCH1((k + 1), 7) = SCH(X2, 12)

ElseIf Left(SCH(X2, 6), 2) = "US" And Left(SCH(X2, 11), 2) = "US" Then

SCH1((k + 1), 7) = "not find"

End If


k = k + 1
        
    End If
    
Next X2


For X4 = 1 To ROW


Sheets("Schedulewk").Cells(X4 + 1, "b") = SCH1(X4, 8)
Sheets("Schedulewk").Cells(X4 + 1, "c") = Left(SCH1(X4, 1), 3)
Sheets("Schedulewk").Cells(X4 + 1, "D") = SCH1(X4, 2)
Sheets("Schedulewk").Cells(X4 + 1, "E") = SCH1(X4, 4)
Sheets("Schedulewk").Cells(X4 + 1, "F") = SCH1(X4, 7)
Sheets("Schedulewk").Cells(X4 + 1, "G") = SCH1(X4, 3)

Next X4

Cells.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlYes
 Range("F:F,G:G").NumberFormat = "[$-en-US]d-mmm;@"
 
     Cells.EntireColumn.AutoFit
    
    MsgBox "Done"


End Sub

3.19 AM_Holds

Sub Hold()

Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook


Workbooks.Open ("\\Cngscapl-spf303\Customer_Care\Doc_Import\Share\AM Team\01 IB - LARA\15 Personal Folder\bOB\Database_Bob.accdb")
Set MyBook2 = ActiveWorkbook
MyBook2.Sheets(2).Copy MyBook1.Sheets("Page1_1")

MyBook1.Sheets("Sheet2").Name = "Holds History"



For z = 4 To Sheets("Page1_1").Range("a65536").End(xlUp).ROW
If Sheets("Page1_1").Cells(z, "o") Like "*day*" Then

Sheets("Page1_1").Cells(z, "q") = Split(Sheets("Page1_1").Cells(z, "o"), " day")

Else

Sheets("Page1_1").Cells(z, "q") = 1

End If
Next z


For x = 4 To Sheets("Page1_1").Range("a65536").End(xlUp).ROW

If Sheets("Page1_1").Cells(x, "L") >= 1 And Sheets("Page1_1").Cells(x, "M") = 0 And Sheets("Page1_1").Cells(x, "q") < 5 And "US" = Left(Sheets("Page1_1").Cells(x, "G"), 2) Then

Sheets("Page1_1").Cells(x, "p") = Sheets("Page1_1").Cells(x, "e") & "," & "DA,"

ElseIf Sheets("Page1_1").Cells(x, "L") = 0 And Sheets("Page1_1").Cells(x, "M") >= 1 And Sheets("Page1_1").Cells(x, "q") < 5 And "US" = Left(Sheets("Page1_1").Cells(x, "G"), 2) Then

Sheets("Page1_1").Cells(x, "p") = Sheets("Page1_1").Cells(x, "e") & "," & ",CS"

ElseIf Sheets("Page1_1").Cells(x, "L") >= 1 And Sheets("Page1_1").Cells(x, "M") >= 1 And Sheets("Page1_1").Cells(x, "q") < 5 And "US" = Left(Sheets("Page1_1").Cells(x, "G"), 2) Then

Sheets("Page1_1").Cells(x, "p") = Sheets("Page1_1").Cells(x, "e") & "," & "DA,CS"

End If

Next x

Sheets.Add
ActiveSheet.Name = "Holds BLs"

k = 2


For Y = 4 To Sheets("Page1_1").Range("P65536").End(xlUp).ROW

If IsError(Application.VLookup(Sheets("Page1_1").Cells(Y, "p"), Sheets("Holds History").Range("A:A"), 1, False)) And Sheets("Page1_1").Cells(Y, "p") <> "" Then

Sheets("Holds BLs").Cells(k, "a") = Sheets("Page1_1").Cells(Y, "p")

k = k + 1

End If


Next Y

For X1 = 1 To Sheets("Holds BLs").Range("a65536").End(xlUp).ROW
Sheets("Holds BLs").Cells(X1, "B") = Split(Sheets("Holds BLs").Cells(X1, "a"), ",")
If Sheets("Holds BLs").Cells(X1, "A") Like "*DA*" Then
Sheets("Holds BLs").Cells(X1, "C") = "DA"
End If
If Sheets("Holds BLs").Cells(X1, "A") Like "*CS*" Then
Sheets("Holds BLs").Cells(X1, "D") = "CS"
End If
Next X1

[b1] = "BL Number"
[c1] = "Usda Hold"
[d1] = "Uscs Hold"
Cells.EntireColumn.AutoFit

ROW1 = MyBook2.Sheets("Sheet2").Range("a65536").End(xlUp).ROW

MyBook2.Sheets("Sheet2").Cells(ROW1 + 1, "A") = Date
MyBook2.Sheets("Sheet2").Cells(ROW1 + 1, "A").Interior.Color = 5296274

For X2 = 2 To MyBook1.Sheets("Holds BLs").Range("a65536").End(xlUp).ROW

MyBook2.Sheets("Sheet2").Cells(ROW1 + 2, "A") = MyBook1.Sheets("Holds BLs").Cells(X2, "A")

ROW1 = ROW1 + 1

Next X2


MyBook2.Save
MyBook2.Close

MsgBox "Done"

End Sub

3.20 AM_Costco

Sub CostcoR()


Dim DISCCO, DESTNCO, DATECO


For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column

If Cells(1, i) = "EQT_ACTY_LAST_FREE_NAME" Then

Cells(1, i) = "LAST FREE DAY(LFD)"

ElseIf Cells(1, i) = "DISC_VOY_REF" Then

DISCCO = Cells(1, i).Column

ElseIf Cells(1, i) = "DEST_NAME" Then

DESTNCO = Cells(1, i).Column

ElseIf Cells(1, i) = "DISC_VSL_ARRIVAL_DT" Then

DATECO = Cells(1, i).Column

End If

Next i



Dim dic

Set dic = CreateObject("scripting.dictionary")

For i = 2 To Cells(Rows.Count, DESTNCO).End(xlUp).ROW

dic(Cells(i, DESTNCO).Value) = ""

Next i

DestName = dic.Keys


Dim MyBook1, MyBook2, MyBook3 As Workbook

Set MyBook1 = ActiveWorkbook

Application.ScreenUpdating = False

'处理总表




'处理数据并复制

For j = 0 To dic.Count - 1



n = DestName(j)

MyBook1.Sheets("COSTO_IMP2").Cells(1, DESTNCO).AutoFilter Field:=DESTNCO, Criteria1:=n & "*"
MyBook1.Sheets("COSTO_IMP2").Cells(1, DISCCO).AutoFilter Field:=DISCCO, Criteria1:="*PL"

Workbooks.Add

Set MyBook2 = ActiveWorkbook

MyBook2.SaveAs MyBook1.Path & "\" & "Costco - " & n & " - " & Format(Date, "yyyy-mm-dd") & ".xlsx"

Sheets.Add
Sheets.Add


MyBook1.Sheets("COSTO_IMP2").Cells.Copy MyBook2.Sheets(1).Cells

MyBook2.Sheets(1).Cells(1, DATECO).AutoFilter Field:=DATECO, Criteria1:=">" & Date + 1

MyBook2.Sheets(1).Cells.Copy MyBook2.Sheets(2).Cells

MyBook2.Sheets(1).AutoFilterMode = False

MyBook2.Sheets(1).Cells(1, DATECO).AutoFilter Field:=DATECO, Criteria1:="<=" & Date + 1

MyBook2.Sheets(1).Cells.Copy MyBook2.Sheets(3).Cells

MyBook2.Sheets(1).AutoFilterMode = False

MyBook1.Sheets(1).AutoFilterMode = False


Sheets(1).Cells.ColumnWidth = 30
Sheets(1).Cells.RowHeight = 20
Sheets(1).Cells.EntireColumn.AutoFit

Sheets(2).Cells.ColumnWidth = 30
Sheets(2).Cells.RowHeight = 20
Sheets(2).Cells.EntireColumn.AutoFit

Sheets(3).Cells.ColumnWidth = 30
Sheets(3).Cells.RowHeight = 20
Sheets(3).Cells.EntireColumn.AutoFit



Sheets(1).Name = n

Sheets(2).Name = "Onboard" & " - " & n

Sheets(3).Name = "Discharged" & " - " & n

MyBook2.Save

MyBook2.Close

Next j


Application.ScreenUpdating = True

MsgBox "Done"




End Sub

Sub CostcoRbeifen()


Dim DISCCO, DESTNCO, DATECO

For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column

If Cells(1, i) = "EQT_ACTY_LAST_FREE_NAME" Then

Cells(1, i) = "LAST FREE DAY(LFD)"

ElseIf Cells(1, i) = "DISC_VOY_REF" Then

DISCCO = Cells(1, i).Column

ElseIf Cells(1, i) = "DEST_NAME" Then

DESTNCO = Cells(1, i).Column

ElseIf Cells(1, i) = "DISC_VSL_ARRIVAL_DT" Then

DATECO = Cells(1, i).Column

End If

Next i


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

For i = 2 To Cells(Rows.Count, DESTNCO).End(xlUp).ROW

dic(Cells(i, DESTNCO).Value) = ""

Next i

DestName = dic.Keys

For i = 0 To dic.Count - 1

MsgBox DestName(i)

Next i


Dim MyBook1, MyBook2, MyBook3 As Workbook

Set MyBook1 = ActiveWorkbook

With Application.FileDialog(msoFileDialogFilePicker)
    .Title = "Select A File"
    .InitialFileName = "C:\Users\GSC.BFU\Desktop\bOB"
    .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)

Set MyBook3 = Workbooks.Open(ipath)
MyBook3.Sheets("DISCHARGED").Copy After:=MyBook1.Sheets(1)
MyBook3.Sheets("ONBOARD").Copy After:=MyBook1.Sheets(1)
MyBook3.Close


Application.ScreenUpdating = False

'处理总表




'处理数据并复制

For j = 0 To dic.Count - 1



n = DestName(j)

MyBook1.Sheets("COSTO_IMP2").Cells(1, DESTNCO).AutoFilter Field:=DESTNCO, Criteria1:=n & "*"
MyBook1.Sheets("COSTO_IMP2").Cells(1, DISCCO).AutoFilter Field:=DISCCO, Criteria1:="*PL"

Workbooks.Add

Set MyBook2 = ActiveWorkbook

MyBook2.SaveAs MyBook1.Path & "\" & "Costco - " & n & " - " & Format(Date, "yyyy-mm-dd") & ".xlsx"

Sheets.Add
Sheets.Add
Sheets.Add


MyBook1.Sheets("COSTO_IMP2").Cells.Copy MyBook2.Sheets(1).Cells

MyBook2.Sheets(1).Cells(1, DATECO).AutoFilter Field:=DATECO, Criteria1:=">" & Date + 1

MyBook2.Sheets(1).Cells.Copy MyBook2.Sheets(2).Cells

MyBook2.Sheets(1).AutoFilterMode = False

MyBook2.Sheets(1).Cells(1, DATECO).AutoFilter Field:=DATECO, Criteria1:="<=" & Date + 1

MyBook2.Sheets(1).Cells.Copy MyBook2.Sheets(3).Cells

MyBook2.Sheets(1).AutoFilterMode = False

MyBook1.Sheets(1).AutoFilterMode = False

MyBook1.Sheets("DISCHARGED").Copy MyBook2.Sheets(1)

MyBook1.Sheets("ONBOARD").Copy MyBook2.Sheets(1)



For i = 1 To Sheets("DISCHARGED").Cells(2, Columns.Count).End(xlToLeft).Column

If Sheets(5).Rows(1).Find(Sheets("DISCHARGED").Cells(2, i)) <> "" Then

Sheets(5).Columns(Sheets(5).Rows(1).Find(Sheets("DISCHARGED").Cells(2, i)).Column).Copy Sheets("DISCHARGED").Columns(i)

End If

Next i


For i = 1 To Sheets("ONBOARD").Cells(2, Columns.Count).End(xlToLeft).Column

If Sheets(4).Rows(1).Find(Sheets("ONBOARD").Cells(2, i)) <> "" Then

Sheets(4).Columns(Sheets(4).Rows(1).Find(Sheets("ONBOARD").Cells(2, i)).Column).Copy Sheets("ONBOARD").Columns(i)

End If

Next i

Sheets(1).Cells.ColumnWidth = 30
Sheets(1).Cells.RowHeight = 20
Sheets(1).Cells.EntireColumn.AutoFit

o = Sheets(1).Cells(Rows.Count, 1).End(xlUp).ROW
p = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column

   Sheets(1).[a1].Resize(o, p).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

Sheets(2).Cells.ColumnWidth = 30
Sheets(2).Cells.RowHeight = 20
Sheets(2).Cells.EntireColumn.AutoFit

Sheets(2).Select

o = Sheets(2).Cells(Rows.Count, 2).End(xlUp).ROW
p = Sheets(2).Cells(1, Columns.Count).End(xlToLeft).Column

   Sheets(2).[a1].Resize(o, p).Select
   
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

Sheets(1).Name = "Onboard Vessel" & " - " & n
Sheets(2).Name = "Discharged" & " - " & n


MyBook2.Save

MyBook2.Close

Next j


Application.ScreenUpdating = True

MsgBox "Done"

End Sub

3.21 AM_CheckAN

Sub ANfailed()
Dim i%, h%
Dim afax As String
Dim myws As Worksheet
Application.ScreenUpdating = False
For i = Sheets.Count To 1 Step -1
    Application.DisplayAlerts = False
    If Sheets(i).Name = "ANfail" Then
        Sheets(i).Delete
    End If
    Application.DisplayAlerts = True
Next
    
Set myws = Sheets.Add(Count:=1)
myws.Name = "ANfail"

i = Sheets("Page1_1").[C666666].End(3).ROW
Sheets("Page1_1").Activate
Range("A13:R" & i).Copy
Sheets("ANfail").Activate
[a1].Select
ActiveSheet.Paste
[s1] = "Total Count"
[t1] = "Carrier"
[u1] = "Fax"
[v1] = "Fax V"
[W1] = "Total S"
i = Sheets("ANfail").[C666666].End(3).ROW

With Range("I1:I" & i)
    .AutoFilter Field:=1, Criteria1:="GN"
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilter
    '.Clear
End With

i = Sheets("ANfail").[C666666].End(3).ROW
For h = 2 To i
    Cells(h, 19) = Application.WorksheetFunction.CountIfs(Range("B1:B" & i), Cells(h, 2), Range("K1:K" & i), "<>")
    Cells(h, 20) = Application.WorksheetFunction.CountIfs(Range("B1:B" & i), Cells(h, 2), Range("K1:K" & i), "Carrier Website")
    If InStr(UCase(Cells(h, 11)), "@FAX") > 0 Then Cells(h, 21) = "Y"
    Cells(h, 22) = Application.WorksheetFunction.CountIfs(Range("B1:B" & i), Cells(h, 2), Range("U1:U" & i), "Y")
    If Range("s" & h) - Range("t" & h) - Range("v" & h) > 0 Then Cells(h, 23) = "D"
Next

With Range("W1:W" & i)
    .AutoFilter Field:=1, Criteria1:="D"
    .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    .AutoFilter
    '.Clear
End With

i = Sheets("ANfail").[C666666].End(3).ROW

With Range("A1:W" & i)
    .Borders.LineStyle = xlContinuous
    .Font.Name = "Arial"
    .Font.Size = 10
End With
Columns("A:W").AutoFit
[a1].Select

MsgBox "Done"

Application.ScreenUpdating = True
End Sub

3.22 AM_CA_CLCheck

Sub locaC()

'fuzhibiaoge

Dim MyBook1 As Workbook
Set MyBook1 = ActiveWorkbook

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\Clarence Location Check\Clarence Location.xlsx")
Set MyBook3 = ActiveWorkbook
MyBook3.Sheets(1).Copy MyBook1.Sheets("Page1_1")
MyBook3.Close
MyBook1.Sheets("sheet1").Name = "Clarence Location"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\Clarence Location Check\Off Dock & Duty Paids Profile.xlsx")
Set MyBook4 = ActiveWorkbook
MyBook4.Sheets(1).Copy MyBook1.Sheets("Page1_1")
MyBook4.Close
MyBook1.Sheets("sheet1").Name = "Off Dock List"

Workbooks.Open ("C:\Users\GSC.BFU\Desktop\bOB\Clarence Location Check\WK29-Off Dock-0TP6GW1PL.xlsx")
Set MyBook5 = ActiveWorkbook
MyBook5.Sheets(1).Copy MyBook1.Sheets("Page1_1")
MyBook5.Close


'Off dock

'IF BAOHAN ZIFU AND CL HOUSIWEI DAYU4
'THEN TIQU CONTAINER BL CUSTOMER CL
'OFF DCOK GAI CHUAN & RIQI & TIAN RU TIQU DE CONTAINER BL CUSTOMER CL


For x7 = 4 To Sheets("Page1_1").Range("a65536").End(xlUp).ROW

If (Sheets("Page1_1").Cells(x7, "n") Like "*Canadian Tire*" Or Sheets("Page1_1").Cells(x7, "n") Like "*CANADIAN TIRE*") _
And _
(Sheets("Page1_1").Cells(x7, "k") Like "*5525*" Or Sheets("Page1_1").Cells(x7, "k") Like "*5491*" _
Or Sheets("Page1_1").Cells(x7, "k") Like "*4222*" Or Sheets("Page1_1").Cells(x7, "k") Like "*4945*") Then

Sheets("Off Dock").Cells(n + 10, "a") = Sheets("Page1_1").Cells(x7, "l")
Sheets("Off Dock").Cells(n + 10, "b") = Sheets("Page1_1").Cells(x7, "d")
Sheets("Off Dock").Cells(n + 10, "c") = Sheets("Page1_1").Cells(x7, "n")
Sheets("Off Dock").Cells(n + 10, "d") = Sheets("Page1_1").Cells(x7, "k")

n = n + 1

End If

If (Sheets("Page1_1").Cells(x7, "n") Like "*FGL Sport*" Or Sheets("Page1_1").Cells(x7, "n") Like "*FGL SPORT*" _
Or Sheets("Page1_1").Cells(x7, "n") Like "*Marks Work*" Or Sheets("Page1_1").Cells(x7, "n") Like "*MARKS WORK*" _
Or Sheets("Page1_1").Cells(x7, "n") Like "*Target*" Or Sheets("Page1_1").Cells(x7, "n") Like "*TARGET*" _
Or Sheets("Page1_1").Cells(x7, "n") Like "*Toys R Us*" Or Sheets("Page1_1").Cells(x7, "n") Like "*TOUS R US*" _
Or Sheets("Page1_1").Cells(x7, "n") Like "*Yamaha*" Or Sheets("Page1_1").Cells(x7, "n") Like "*YAMAHA*") Then

Sheets("Off Dock").Cells(n + 10, "a") = Sheets("Page1_1").Cells(x7, "l")
Sheets("Off Dock").Cells(n + 10, "b") = Sheets("Page1_1").Cells(x7, "d")
Sheets("Off Dock").Cells(n + 10, "c") = Sheets("Page1_1").Cells(x7, "n")
Sheets("Off Dock").Cells(n + 10, "d") = Sheets("Page1_1").Cells(x7, "k")
Sheets("Off Dock").Cells(n + 10, "d").Interior.Color = 255

n = n + 1

End If

Next x7

Sheets("Off Dock").[b4] = Sheets("Page1_1").[e4]
Sheets("Off Dock").[d3] = Date


'Schenker

Sheets.Add
Sheets("Sheet4").Name = "Schenker"

Dim ROW As Integer
Dim SKER()

ROW = Sheets("Page1_1").Range("b65536").End(xlUp).ROW

ReDim SKER(1 To ROW, 1 To 5)

For X1 = 4 To ROW

If Sheets("Page1_1").Cells(X1, "N") Like "*SCHENKER*" Or Sheets("Page1_1").Cells(X1, "N") Like "*Schenker*" Then

SKER(X1, 1) = Sheets("Page1_1").Cells(X1, "D")
SKER(X1, 2) = Sheets("Page1_1").Cells(X1, "L")
SKER(X1, 3) = Sheets("Page1_1").Cells(X1, "J")
SKER(X1, 4) = Sheets("Page1_1").Cells(X1, "N")

End If

If Sheets("Page1_1").Cells(X1, "I") <> "" Then

SKER(X1, 5) = Sheets("Page1_1").Cells(X1, "I") & Sheets("Page1_1").Cells(X1, "J") & Sheets("Page1_1").Cells(X1, "K")

ElseIf Sheets("Page1_1").Cells(X1, "I") = "" Then

SKER(X1, 5) = Sheets("Page1_1").Cells(X1, "H") & Sheets("Page1_1").Cells(X1, "J") & Sheets("Page1_1").Cells(X1, "K")

End If

Next X1

For X2 = 4 To ROW

If SKER(X2, 1) <> "" Then

Sheets("Schenker").Cells(k + 2, "A") = SKER(X2, 1)
Sheets("Schenker").Cells(k + 2, "B") = SKER(X2, 2)
Sheets("Schenker").Cells(k + 2, "C") = SKER(X2, 3)
Sheets("Schenker").Cells(k + 2, "D") = SKER(X2, 4)

k = k + 1

End If

Next X2

Sheets("Schenker").[a1] = "BKH - Booking Ref"
Sheets("Schenker").[b1] = "EQ - Container Number"
Sheets("Schenker").[c1] = "BKH - Customs Clearance"
Sheets("Schenker").[d1] = "PARC - Full Name (Consignee) (Manual)"

    Sheets("Schenker").Cells.EntireColumn.AutoFit
    


'Clarence Location cEHCKE

Sheets.Add

Sheets("Sheet5").Name = "Clarence Location Error BL"

For X3 = 2 To Sheets("Clarence Location").Range("b65536").End(xlUp).ROW

Sheets("Clarence Location").Cells(X3, "D") = Sheets("Clarence Location").Cells(X3, "A") & Sheets("Clarence Location").Cells(X3, "B") & Sheets("Clarence Location").Cells(X3, "C")

Next X3


For X4 = 1 To ROW

If IsError(Application.VLookup(SKER(X4, 5), Sheets("Clarence Location").Range("D:D"), 1, False)) Then

Sheets("Clarence Location Error BL").Cells(m + 1, "A") = Sheets("Page1_1").Cells(X4, "D")

m = m + 1

End If

Next X4

Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlNo

On Error Resume Next

For X5 = 1 To Sheets("Clarence Location Error BL").Range("A65536").End(xlUp).ROW

Cells(X5, "B") = Sheets("Page1_1").Range("D:D").Find(Cells(X5, "A")).Offset(0, 3)
Cells(X5, "C") = Sheets("Page1_1").Range("D:D").Find(Cells(X5, "A")).Offset(0, 4)
Cells(X5, "D") = Sheets("Page1_1").Range("D:D").Find(Cells(X5, "A")).Offset(0, 5)
Cells(X5, "E") = Sheets("Page1_1").Range("D:D").Find(Cells(X5, "A")).Offset(0, 6)
Cells(X5, "F") = Sheets("Page1_1").Range("D:D").Find(Cells(X5, "A")).Offset(0, 7)

Next X5

On Error GoTo 0


   Sheets("Clarence Location Error BL").Cells.EntireColumn.AutoFit
   
   'Off dock



MsgBox "Done"



End Sub

3.23 EMAIL_SEND

Sub SendEM()

If [a1] = "" And [a2] = "" Then
 Columns("A:A").Delete
 End If
 
On Error Resume Next

ActiveSheet.Name = "1-20 Email Address"

'SHANDIAO ssc.krexportdocs@cma-cgm.com 无效公邮



For X1 = 2 To Sheets("1-20 Email Address").Range("F65536").End(xlUp).ROW

If Sheets("1-20 Email Address").Cells(X1, "F") = "ssc.krexportdocs@cma-cgm.com" Then
Sheets("1-20 Email Address").Cells(X1, "F").ClearContents

End If
Next X1

For X2 = 2 To Sheets("1-20 Email Address").Range("G65536").End(xlUp).ROW

If Sheets("1-20 Email Address").Cells(X2, "G") = "ssc.krexportdocs@cma-cgm.com" Then
Sheets("1-20 Email Address").Cells(X2, "G").ClearContents

End If
Next X2

Dim dic

Set dic = CreateObject("scripting.dictionary")

For x = 2 To Sheets("1-20 Email Address").Range("a65536").End(xlUp).ROW


dic(Sheets("1-20 Email Address").Cells(x, "a").Value) = dic(Sheets("1-20 Email Address").Cells(x, "a").Value) & Sheets("1-20 Email Address").Cells(x, "f").Value & ";"

Next x



Sheets("1-20 Email Address").Range("h2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("1-20 Email Address").Range("i2").Resize(dic.Count) = Application.Transpose(dic.Items)



For Y = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

Sheets("1-20 Email Address").Cells(k + 2, "j") = Sheets("Page1_1").Range("A:A").Find(Sheets("1-20 Email Address").Cells(Y, "h")).Offset(0, 9).Value
Sheets("1-20 Email Address").Cells(k + 2, "k") = Sheets("Page1_1").Range("K:K").Find(Sheets("1-20 Email Address").Cells(Y, "h").Value).Offset(0, 4).Value

k = k + 1

Next Y

Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets("1-20 Email Address").Range("H65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets("1-20 Email Address").Cells(i, "H")
ETA = Sheets("1-20 Email Address").Cells(i, "J")
T = Sheets("1-20 Email Address").Cells(i, "I")
DPc = Sheets("1-20 Email Address").Cells(i, "k")


With outlookitem

.Display


.To = T
.CC = "gsc.northchinaimport@cma-cgm.com;bob.fu@apl.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub




Sub AMEmailSend()

Dim i, BL, CN, PC, PN, SD, POL As String
SD = "bob.fu@apl.com"


Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "LARA US-NO EMAIL FOR AN BL:"
bodytext = "APL.Customer.Care,"
bodytext1 = "Please kindly provide email address of "
bodytext2 = " for sending AN & invoice, and also contact customer the AN sent failed due to no email, thanks."
bodytext3 = "BL:"
bodytext4 = "Partner Code:"
bodytext5 = "Contact Name: "
bodytext6 = "POL:"




'kaishixunhuan

For i = 2 To Range("b65536").End(xlUp).ROW


receiver = "APL.Customer.Care;"

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Cells(i, "b")
CN = Cells(i, "i")
PC = Cells(i, "j")
PN = Cells(i, "k")
POL = Cells(i, "d")




With outlookitem

.Display

.To = receiver
.CC = SD
.Subject = subjecttext & BL
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & CN & bodytext2 & "<br/><br/>" & bodytext3 & BL & "<br/><br/>" & bodytext6 & POL & "<br/><br/>" & bodytext4 & PC & "<br/><br/>" & bodytext5 & PN & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub


Sub NoAnNoEmial()

On Error Resume Next
ActiveSheet.Name = "1-20 Email Address"

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

For x = 2 To Sheets("1-20 Email Address").Range("a65536").End(xlUp).ROW


dic(Sheets("1-20 Email Address").Cells(x, "a").Value) = dic(Sheets("1-20 Email Address").Cells(x, "a").Value) & Sheets("1-20 Email Address").Cells(x, "f").Value & ";"

Next x


Sheets("1-20 Email Address").Range("h2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets("1-20 Email Address").Range("M2").Resize(dic.Count) = Application.Transpose(dic.Items)

For Y = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

Sheets("1-20 Email Address").Cells(k + 2, "I") = Sheets("Page1_1").Range("B:B").Find(Sheets("1-20 Email Address").Cells(Y, "h")).Offset(0, 4).Value
Sheets("1-20 Email Address").Cells(k + 2, "J") = Sheets("Page1_1").Range("B:B").Find(Sheets("1-20 Email Address").Cells(Y, "h").Value).Offset(0, 6).Value
Sheets("1-20 Email Address").Cells(k + 2, "L") = Date + 3

k = k + 1

Next Y


'查找code

    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=" & "\\Cngscapl-spf302\IB\AM Team\01 IB - LARA\15 Personal Folder\bOB\SHA Email Ask Atuo\DP Code.xlsx"
    
  
  
  rst.Open "select *  from [Sheet1$]", conn, adOpenKeyset, adLockOptimistic
  
    On Error Resume Next
For z = 2 To Sheets("1-20 Email Address").Range("h65536").End(xlUp).ROW

If Len(Sheets("1-20 Email Address").Cells(z, "I")) > 6 Then

Cells(z, "K") = rst.Fields(Sheets("1-20 Email Address").Cells(z, "J") & Right(Sheets("1-20 Email Address").Cells(z, "I").Value, 2))

Else

Cells(z, "K") = rst.Fields(Sheets("1-20 Email Address").Cells(z, "J") & "MA")


End If

Next z
  On Error GoTo 0



Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets("1-20 Email Address").Range("H65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets("1-20 Email Address").Cells(i, "H")
ETA = Sheets("1-20 Email Address").Cells(i, "l")
T = Sheets("1-20 Email Address").Cells(i, "M")
DPc = Sheets("1-20 Email Address").Cells(i, "K")


With outlookitem

.Display


.To = T
.CC = "GSC.BFU@cma-cgm.com;gsc.northchinaimport@cma-cgm.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing

End Sub

3.24 ALL_EMAIL_SEND

Sub email_s()


Call FINDStatus

'SHANDIAO ssc.krexportdocs@cma-cgm.com 无效公邮



For X1 = 2 To Sheets(1).Range("a65536").End(xlUp).ROW

If LCase(Sheets(1).Cells(X1, "g").Value) = "ssc.krexportdocs@cma-cgm.com" Or LCase(Sheets(1).Cells(X1, "g").Value) = "twn.booking@cma-cgm.com" _
Or LCase(Sheets(1).Cells(X1, "g").Value) = "ssc.indexportdocs@cma-cgm.com" Then 'ssc.indexportdocs@cma-cgm.com
Sheets(1).Cells(X1, "g").ClearContents

End If
Next X1

For X2 = 2 To Sheets(1).Range("a65536").End(xlUp).ROW

If LCase(Sheets(1).Cells(X2, "h").Value) = "ssc.krexportdocs@cma-cgm.com" Or LCase(Sheets(1).Cells(X2, "h").Value) = "twn.booking@cma-cgm.com" _
Or LCase(Sheets(1).Cells(X2, "h").Value) = "ssc.indexportdocs@cma-cgm.com" Then
Sheets(1).Cells(X2, "h").ClearContents

End If
Next X2


Dim dic

Set dic = CreateObject("scripting.dictionary")

For x = 2 To Sheets(1).Range("a65536").End(xlUp).ROW


dic(Sheets(1).Cells(x, "a").Value) = dic(Sheets(1).Cells(x, "a").Value) & Sheets(1).Cells(x, "g").Value & ";"

Next x



Sheets(1).Range("I2").Resize(dic.Count) = Application.Transpose(dic.Keys)
Sheets(1).Range("J2").Resize(dic.Count) = Application.Transpose(dic.Items)


Dim outlookapp As Outlook.Application
Dim outlookitem As Outlook.mailitem

Set outlookapp = New Outlook.Application


subjecttext = "Missing CNEE's email address for BL#"
subjecttext1 = "    *Arrival-Notice Sending Purpose*    ETA:"
subjecttext2 = "   DPcode:"
bodytext = "Dear POL Colleague,"
bodytext1 = "Please provide CEE's email address for sending AN, thanks."
bodytext2 = "BL:"



'kaishixunhuan

For i = 2 To Sheets(1).Range("A65536").End(xlUp).ROW

Set outlookitem = outlookapp.createitem(olmailitem)

BL = Sheets(1).Cells(i, "I")
ETA = Sheets(1).Cells(i, "F")
T = Sheets(1).Cells(i, "J")
DPc = Sheets(1).Cells(i, "E")


With outlookitem

.Display


.To = T
.CC = "gsc.northchinaimport@cma-cgm.com;bob.fu@apl.com"
.SendUsingAccount = outlookapp.Session.Accounts.Item(2)
.Subject = subjecttext & BL & subjecttext1 & ETA & subjecttext2 & DPc
.HTMLBody = bodytext & "<br/><br/>" & bodytext1 & "<br/><br/>" & bodytext2 & BL & .HTMLBody


End With

Set outlookitem = Nothing
Set Y = Nothing

Next i

Set outlookapp = Nothing


End Sub