Hello,
I am trying to create a loop for the code below. I need the code to start with what is in Cell Q2 then loop all the way through either the Actualized or NotActualized functions and back to the "For Each" statement. Any ideas? FYI, the cell R2 in the functions will need to become R3, R4, etc... please help a noob! thanks!
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 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 'User Id=userId" & "; Password=" & "password" 'The statement above has been commented out. I use the statement below to prompt the user for the userId and password - which is what I prefer! con.ConnectionString = dbConnectStr 'con.Properties("Prompt") = adPromptAlways con.Open dbConnectStr 'ConnectionString 'Record locking recset.CursorType = adOpenKeyset recset.LockType = adLockOptimistic With recset 'This is an example SQL code that you might want to run 'Select * From MyTable SQL_String = "SELECT DISTINCT busr_id," 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 Set MyRange = ActiveSheet.Range("A2:A65536") On Error GoTo 0 'If an invalid range is entered then exit If MyRange Is Nothing Then Exit Sub MatchString = 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 there are valid matches then delete the rows If Not DelRange Is Nothing Then DelRange.EntireRow.Delete ActiveSheet.UsedRange.Borders.Value = 1 '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 some overdue PO Milestone Dates. Let's correct them." End If ActiveSheet.Range("Q2").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("Q2:Q" & LastRow).FillDown ActiveSheet.Range("R2").FormulaR1C1 = "=RC[-14] & "" - "" & RC[-8]" LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row If LastRow > 2 Then Range("R2:R" & LastRow).FillDown ActiveSheet.Range("Q2").Select For Each cell In Range("Q2:Q" & LastRow) MSG1 = MsgBox(ActiveCell.Value, vbYesNo, "Task Completed?") If MSG1 = vbYes Then Actualized Else NotActualized End If End Sub Function Actualized() With UserForm1 .Caption = ActiveSheet.Range("R2") .StartUpPosition = 0 .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width) .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height) .Show End With Next cell End Function Function NotActualized() With UserForm2 .Caption = ActiveSheet.Range("R2") .StartUpPosition = 0 .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width) .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height) .Show End With Next cell End Function
Reply With Quote
