VBA, matching values and time synchronizing

[cliodne]

I have a few questions, and help with any or all would be greatly
appreciated.

- My first problem is that my program is time dependent, so in VBA I
need to start by re-setting the time on the computer to a specific
time. I was told that I could synchronize the time by referencing a
website that has the current time. I have a site, but I'm lost on what
code would enable me to do this.

- My second problem is that I have two sheets, each with different
data on the same topic, and in a third sheet, the data from the two
prior sheets will match one column of data, compiling them into this
third new one. Is there a way to not only match the data absolutely,
but also partly, such as four characters out of five? I'm thinking
that the Match and VLookup formulas would be best, or even if I made
the columns into ranges and did a simple If statment: If
columnAsheet1(i) = columnBsheet2(i) then
carry out theses calcs... But then that doesn't account for the not
absolute case.

Thank you very much,
Cami

 

[Bob Phillips]

Attached is a sub by Bill James, adapted to VBA by Dana DeLouis which
connects to a central clock and gets the time. You could run this on
workbook open.

For the second part, the VBA Like command should be what you want.

Option Explicit

Sub SetClock()
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'SetTime2.vbs - Adjusts system time if off by 1 second or more.
'© Bill James - (e-mail address removed) - rev 28 Apr 2000
'Credit to Michael Harris for original concept.
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'Please Note: Original code adjusted here to work from within Excel VBA
'Issues: If Clock is updated at exactly 23:59:57, and your clock is
' 10 seconds ahead (into the next day), the day warning may not be
' appropriate.

' A future version may want to redo a clock update close to midnight
' before returning any results.

' Making this a function may be nice.
' A return code could indicate the status.
' Examples:
' Too much time delay - bad connection.
' Close to Midnight
' Clock time is surprisingly off by a set amount.
' ** You may want to know if your clock was way off
' ** in case you just ran or printed some important documents or
reports.

' Dana DeLouis.
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
Dim ws
Dim http
Dim n As Long
Dim sMessage As String
Dim TimeOffset, HexVal
Dim DatesMessage, TimesMessage
Dim TimeChk, LocalDate, Lag, GMT_Time

Const sMsgTitle As String = "SetTime.vbs © Bill James"
Const USNO As String = "http://tycho.usno.navy.mil/cgi-bin/timer.pl"
Const sMessageOk As String = "System is accurate to within 1 second." &
vbNewLine & _
"System time not changed."
Const strTimeOffset As String = _
"HKLM\SYSTEM\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias"


'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
'// Speech stuff...
Const spkClockOk As String = "Clock checks ok!"
Const spkClockAdj As String = "Clock adjusted by # seconds"
Const spkDayWarning As String = "Warning. Your clock is off by more
than 1 day."
'// = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

Set ws = CreateObject("WScript.Shell")

'Check system compatibility.
On Error Resume Next
Set http = CreateObject("Microsoft.XMLHTTP")
If Err.Number <> 0 Then
sMessage = "Process Aborted!" & vbNewLine & vbNewLine & _
"Minimum system requirements to run this" & vbNewLine & _
"script are Windows 95 or Windows NT 4.0" & vbNewLine & _
"with Internet Explorer 5."

MsgBox sMessage, vbCritical, sMsgTitle
GoTo Cleanup
End If


'Read time zone offset hex value from Registry.
TimeOffset = ws.RegRead(strTimeOffset)


' = = = = = Current Code = = = = = = = = = = = = = =
' Reg value format varies between Win9x and NT
If IsArray(TimeOffset) Then
'Win9x uses a reversed 4 element array of Hex values.
HexVal = Hex(TimeOffset(3)) & Hex(TimeOffset(2)) & _
Hex(TimeOffset(1)) & Hex(TimeOffset(0))
Else 'Must be NT system.
HexVal = Hex(TimeOffset)
End If
'Convert to hours of time zone offset.
TimeOffset = -CLng("&H" & HexVal) / 60
' = = = = = = = = = = = = = = = = = = = = = = = = = =


' = = = = = = = = = = = = = = = = = = = = = = = = = =
' Not sure, but the above code looks like it could be
' reduced on my system to this:


' TimeOffset = -CLng(TimeOffset / 60)
' = = = = = = = = = = = = = = = = = = = = = = = = = =


'Get time from server. Recheck up to 5 times if lagged.
For n = 1 To 5
'Fetch time page from US Naval Observatory web page.
http.Open "GET", USNO & Now(), False, "<proxy login>", "<password>"


'Check response time to avoid invalid errors.
TimeChk = Now
http.send
LocalDate = Now
Lag = DateDiff("s", TimeChk, LocalDate)
If Lag < 2 Then Exit For
Next
'
'If still too much lag after 5 attempts, quit.
If n > 5 Then
sMessage = "Unable to establish a reliable connection"
sMessage = sMessage & "with time server. This could be due to the "
sMessage = sMessage & "time server being too busy, your connection "
sMessage = sMessage & "already in use, or a poor connection."
sMessage = sMessage & vbLf & vbLf
sMessage = sMessage & "Please try again later."


MsgBox sMessage, vbInformation, vbOKOnly
GoTo Cleanup
End If


'Just read Header date.
GMT_Time = http.getResponseHeader("Date")


' = = = = = = = = = = = = = = = = = = = = = = = = = =
' My Note:
' Future idea may be to use
' GMT_Time = http.responseText
' and extract the time for your particular time zone.
' I would want to extract the Eastern Time Zone
' perhaps using a Regular Expression.


' Any thoughts on this?
' Thanks
' Dana DeLouis
' (e-mail address removed)


' <BR> May 28, 2004, 10:37:10 Eastern Daylight Time


' = = = = = = = = = = = = = = = = = = = = = = = = = =


GMT_Time = Mid$(GMT_Time, 6, Len(GMT_Time) - 9)


'Time and date error calculations.
Dim NewNow, NewDate, NewTime
Dim RemoteDate, diff, dDiff, tDiff


'Add local time zone offset to GMT returned from USNO server.
RemoteDate = DateAdd("h", TimeOffset, GMT_Time)


'Calculate seconds difference between remote and local.
diff = DateDiff("s", LocalDate, RemoteDate)


'Adjust for difference and lag to get actual time.
NewNow = DateAdd("s", diff + Lag, Now)


'Split out date and calculate any difference.
NewDate = DateValue(NewNow)
dDiff = DateDiff("d", Date, NewDate)


'Split out time.
NewTime = Format(TimeValue(NewNow), "hh:mm:ss")
tDiff = DateDiff("s", Time, NewTime)


'Adjust local time if off by 1 or more seconds.
If Abs(tDiff) < 2 Then
TimesMessage = sMessageOk
MsgBox spkClockOk, True, , True
Else
'Run DOS Time command in hidden window.
ws.Run "%comspec% /c time " & NewTime, 0
TimesMessage = "System time adjusted by " & tDiff & " seconds."
MsgBox Replace(spkClockAdj, "#", tDiff), True, , True
End If
'
'Adjust Date if necessary
If dDiff <> 0 Then
'Run DOS Date command in hidden window.
ws.Run "%comspec% /c date " & NewDate, 0
DatesMessage = "Date adjusted by " & dDiff
MsgBox spkDayWarning, True, , True
End If


'Show the changes
If Abs(tDiff) < 2 And dDiff = 0 Then
ws.Popup DatesMessage & vbLf & TimesMessage, 3, sMsgTitle
Else
ws.Popup DatesMessage & vbLf & TimesMessage, 4, sMsgTitle
End If
'
Cleanup:
Set ws = Nothing
Set http = Nothing
End Sub







--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[cliodne]

Thanks Bob

wow, for that time synchronizing, I thought there would be a simpler
way.

For the matching issue, I'm still confused. I know the functions that
would enable me to be able to match data from a single sheet using the
match, vlookup function, but I don't see how I can use them to take
data from two different sheets, match the values (5 out of 5, 4 out of
5, 3 out of 5, 2 out of 5, 1 out of 5) and compile them into a third
sheet in that order.

Cami

 

[Bob Phillips]

Unless MS provided some mechanism, it is a surprisingly simple way IMO. You
need to get the data from somewhere, such as the Navy clock, then parse it
and apply it.

On the second bit, you need to loop through all the items, match it against
the second sheet, and if matched, copy it. Something like this one that I
provided for someone earlier

Sub Test4Ed()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim iLastRow As Long
Dim iPos As Long
Dim i As Long

Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")

With sh1
iLastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For i = 1 To iLastRow
iPos = 0
On Error Resume Next
iPos = Application.Match(.Cells(i, "D").Value, _
sh2.Range("D"), 0)
On Error GoTo 0
If iPos > 0 Then
sh2.Cells(iPos, "A").Resize(, 3).Copy .Cells(i, "A")
End If
Next i
End With

End Sub

--

HTH

RP
(remove nothere from the email address if mailing direct)