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
vba_ancomments_add
最新推荐文章于 2024-07-19 17:34:15 发布