Consulting

Results 1 to 2 of 2

Thread: Need help with Loop??

  1. #1
    VBAX Regular
    Joined
    Nov 2012
    Posts
    57
    Location

    Need help with Loop??

    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

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,903
    Location
    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/show...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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •