Sub ActivityLogger()
'
' ActivityLogger Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
Dim k As Integer
Dim cnt As Integer
Dim ws As Worksheet
Dim MyRange As Range, DelRange As Range, C As Range, cell As Range
Dim Cll As Excel.Range
Dim MatchString As String, SearchColumn As String, ActiveColumn As String
Dim FirstAddress As String, NullCheck As String
Dim AC
Dim LastRow As Long
Dim SQL_String As String
Dim dbConnectStr As String
Dim con As ADODB.Connection
Dim msg1 As String
Dim i As Integer
Dim recset As ADODB.RecordSet
Dim Col As Integer, Row As Long, s As String
Set con = New ADODB.Connection
Set recset = New ADODB.RecordSet
Dim recordCount As Long
dbConnectStr = "Provider=msdaora;User ID=;Password=;Data Source=" & ";"
Application.ScreenUpdating = False
con.ConnectionString = dbConnectStr
'con.Properties("Prompt") = adPromptAlways
con.Open dbConnectStr 'ConnectionString
' Record locking
recset.CursorType = adOpenKeyset
recset.LockType = adLockOptimistic
With recset
'SQL Query to retrieve stale dates
SQL_String = "SELECT DISTINCT busr_id,"
SQL_String = SQL_String & " alog_seqno,"
SQL_String = SQL_String & " busr_email,"
SQL_String = SQL_String & " SYSDATE,"
SQL_String = SQL_String & " po_number,"
SQL_String = SQL_String & " po_desc,"
SQL_String = SQL_String & " 'PO',"
SQL_String = SQL_String & " po_seqno,"
SQL_String = SQL_String & " po_revno,"
SQL_String = SQL_String & " alog_keylabel,"
SQL_String = SQL_String & " alog_desc,"
SQL_String = SQL_String & " alog_schedule_date,"
SQL_String = SQL_String & " alog_forecast_date,"
SQL_String = SQL_String & " alog_actual_date,"
SQL_String = SQL_String & " busr_firstname,"
SQL_String = SQL_String & " busr_lastname,"
SQL_String = SQL_String & " po_release_number"
SQL_String = SQL_String & " FROM bps_users,"
SQL_String = SQL_String & " po_personnel_assigns,"
SQL_String = SQL_String & " po_headers,"
SQL_String = SQL_String & " activities,"
SQL_String = SQL_String & " milestones"
SQL_String = SQL_String & " WHERE po_alog_seqno_next = alog_seqno"
SQL_String = SQL_String & " AND alog_forecast_date < TRUNC (SYSDATE)"
SQL_String = SQL_String & " AND NVL (po_sentexpedition, 0) = 0"
SQL_String = SQL_String & " AND alog_actual_date IS NULL"
SQL_String = SQL_String & " AND po_complete_cancelflag NOT IN ('C', 'X', 'D')"
SQL_String = SQL_String & " AND po_seqno = popa_po_seqno"
SQL_String = SQL_String & " AND mstn_value = alog_keylabel"
SQL_String = SQL_String & " AND popa_relationship ="
SQL_String = SQL_String & " Case mstn_category"
SQL_String = SQL_String & " WHEN 'Purchasing' THEN 'BUYER'"
SQL_String = SQL_String & " WHEN 'Expediting' THEN 'EXPEDITOR'"
SQL_String = SQL_String & " WHEN 'Engineering' THEN 'REQUESTOR'"
SQL_String = SQL_String & " Else 'BUYER'"
SQL_String = SQL_String & " End"
SQL_String = SQL_String & " AND popa_busr_id = busr_id"
recset.Open Source:=SQL_String, ActiveConnection:=con
' Write the field names
For Col = 0 To .Fields.Count - 1
Range("A1").Offset(0, Col).Value = recset.Fields(Col).Name
Next Col
' Write the recordset
Range("A1").Offset(1, 0).CopyFromRecordset recset
Dim a As Variant
.MoveFirst
'a = recset.GetRows
'MsgBox LBound(a), , UBound(a)
'MsgBox a(0), , a(1)
If .recordCount < 1 Then Goto endnow
.MoveFirst
For Row = 0 To (.recordCount - 1)
'Debug.Print CStr(.Fields(Row).Value)
.MoveNext
Next Row
End With
endnow:
Set recset = Nothing
con.Close
Set con = Nothing
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)
On Error Resume Next
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set MyRange = ActiveSheet.Range("A2:A" & LastRow)
On Error Goto 0
'begin filter by BUN
If MyRange Is Nothing Then Exit Sub
MatchString = VBA.Environ("username")
For Each Cll In MyRange.Cells
If InStr(1, Cll.Value, MatchString, vbTextCompare) = 0 Then
If DelRange Is Nothing Then Set DelRange = Cll Else Set DelRange = Union(DelRange, Cll)
End If
Next Cll
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
'Indicate the number of stale dates
ActiveSheet.Range("T2").FormulaR1C1 = "=COUNTIF(C[-19],RC[-19])"
'determine whether there are stale dates
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If LastRow < 2 Then
MsgBox "You have no overdue PO Milestone Dates."
ActiveWorkbook.Close False
Else
MsgBox "You have " & ActiveSheet.Range("T2").Value & " overdue PO Milestone Date(s). Let's correct them."
End If
ActiveSheet.Range("R2").FormulaR1C1 = _
"=""The "" & RC[-7] & "" milestone for "" & RC[-13] & "" is stale. Has this task been completed?"""
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If LastRow > 2 Then Range("R2:R" & LastRow).FillDown
ActiveSheet.Range("S2").FormulaR1C1 = "=RC[-14] & "" - "" & RC[-8]"
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If LastRow > 2 Then Range("S2:S" & LastRow).FillDown
ActiveSheet.UsedRange.Borders.Value = 1
'Change date format
Range("D:D,L:L,M:M,N:N").Select
selection.NumberFormat = "mm-dd-yyyy;@"
'begin loop of user input
For i = 2 To LastRow
ActiveSheet.Range("R" & i).Select
msg1 = MsgBox(ActiveCell.Value, vbYesNo, "Task Completed?")
If msg1 = vbYes Then
ActiveSheet.Range("N" & i).Select
Actualized (i)
SQL_String = "UPDATE activities "
SQL_String = SQL_String & " SET ALOG_ACTUAL_DATE = TO_DATE('" & VBA.Format(ActiveSheet.Range("N" & i).Value, "mm-dd-yyyy") & "', 'mm-dd-yyyy') "
SQL_String = SQL_String & " WHERE ALOG_SEQNO = " & ActiveSheet.Range("B" & i)
DoCmd.RunSQL SQL_String
Else
ActiveSheet.Range("M" & i).Select
NotActualized (i)
SQL_String = "UPDATE activities "
SQL_String = SQL_String & " SET ALOG_FORECAST_DATE = TO_DATE('" & VBA.Format(ActiveSheet.Range("M" & i).Value, "mm-dd-yyyy") & "', 'mm-dd-yyyy') "
SQL_String = SQL_String & " WHERE ALOG_SEQNO = " & ActiveSheet.Range("B" & i)
DoCmd.RunSQL SQL_String
End If
Next i
End Sub
I have bolded the line where the error occurs.
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks