PDA

View Full Version : Help with Date Picker 6.0??



jsabo
08-13-2013, 02:25 PM
Hello,

I am having a problem where during a loop, i select multiple dates from the date picker and my VBA code is supposed to paste the value selected in column M, increasing the row number each time. The problem I am currently having is that if the code loops, say, three times, the last selected date from the date picker gets pasted three times.


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.Range("S2").FormulaR1C1 = "=COUNTIF(C[-18], RC[-18])"
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 stale PO Milestone Dates."
ActiveWorkbook.Close False
Else
MsgBox "You have " & ActiveSheet.Range("S2").Value & " stale 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 I = 2 To LastRow
MSG1 = MsgBox(ActiveCell.Value, vbYesNo, "Task Completed?")
If MSG1 = vbYes Then
Actualized (I)
Else
NotActualized (I)
End If
ActiveCell.Offset(1, 0).Select
Next IEnd Sub


Function Actualized(RowNum As Integer)
With UserForm1
.Caption = ActiveSheet.Range("R" & RowNum)
.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
End Function


Function NotActualized(RowNum As Integer)
With UserForm2
.Caption = ActiveSheet.Range("R" & RowNum)
.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
End Function

This next part shows the code when a user selects from the Actualized() function (contains the DTPicker1 value) and runs the code from UserForm1:


Private Sub CommandButton1_Click()
Dim LastRow As Long
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For I = 2 To LastRow
ActiveSheet.Range("M" & I) = DTPicker1.Value
'ActiveCell.Offset(1, 0).Select
Next I
Unload UserForm1
End Sub


Private Sub CommandButton2_Click()
Unload UserForm1
ActiveWorkbook.Close SaveChanges:=False
End Sub


Command button 1 is supposed to accept the selected date from the picker and paste it into column M and I is supposed to move the row down by one each time. The row is moving down, but it only seems to paste the last date selected repeatedly.

Any ideas? Kind of confusing, let me know if i can clarify.

Kenneth Hobs
08-13-2013, 03:37 PM
IF I = 3 then M2 and M3 would get the value. Was that not what you wanted? Find may not be the best way to find the last row. Use F8 to step through the code to debug it and find our what LastRow is found.

jsabo
08-13-2013, 04:24 PM
No, not exactly what I wanted. M2 through M4 for instance should have different values in each depending on what was picked (independent, discreet dates based on multiple user selections). As for the LastRow, it seems to be finding the last row correctly. Stumped here.

Kenneth Hobs
08-13-2013, 05:02 PM
Your functions return nothing. I am not sure if the DTPicker1.Value is a string or a datetime. For this example, let's assume that it is a string and that in the dialog you set DTPicker1.Value=x.

Function Actualized(RowNum As Integer) as String
With UserForm1
.Caption = ActiveSheet.Range("R" & RowNum)
.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
Actualized = x
End Function