Need help with Loop??

[jsabo]

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

[Kenneth Hobs]

Maybe you can use your famous gleaming skill and get what you need from one of my latest posts for method 3 at: http://www.vbaexpress.com/forum/showthread.php?46880-vba-code-import-table-excel-to-mysql

If not, and no response later tonight, I will look into your code more.

In the referenced thread, I used a string concatenation method for an SQL INSERT string. When dealing with long string concatenations, it would be best to poke the strings into an array and then use Join() to join the array elements into the final string. I am not sure how long SQL strings can be but at some point, the arrays and then Join() will start to shine. Besides which, the code looks more clean and easy to maintain when you poke the strings into a string array.