vba_ancomments_add

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