So I've got this Excel workbook that has some macro's. Users are presented with a button to either create a worksheet with the current date as name, or enter a date manually and that worksheet will be created.
Now the issue: The worksheet has two sheet ('Initial' and 'Version') that must be first and last. However, all worksheets created in between should be sorted on date everytime a new sheet is created. And I mean sorted on date, the sheets are 'DD-MM-YY' so e.g. I could have names like '1-11-21', '2-11-21', '11-11-21' and '21-11-21' in the same workbook and it should be sorted ascending.
Any suggestions? A normal sort just messes things up I found (1-11-21 and 11-11-21, followed by '2-11-21' and '21-11-21'....
Thanks,
Jasper
Sorting sheets of a workbook is rather easy, there a numerous examples out there, looking more or less like this:
Sub SortSheets(Optional wb As Workbook = Nothing)
If wb Is Nothing Then Set wb = ActiveWorkbook ' (or maybe ThisWorkbook)
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = 1 To wb.Worksheets.Count - 1
For j = i + 1 To wb.Worksheets.Count
' ==> The following line needs to be replaced!
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
wb.Worksheets(j).Move before:=wb.Worksheets(i)
End If
Next j
Next i
' Application.ScreenUpdating = True
End Sub
The only logic you need to change now is the If-statement. Instead of comparing the names of the sheets, you need to find a custom logic that compares the names of the two sheets.
Your logic is basically: If the name is Initial, sort it to the top, if it is Version, sort it to the end and for all the others, sort them by the date the name is representing.
I created a small function that calculates a number from the name. The Initial sheets gets 0, the Version gets a arbitrary high number, a worksheet with a date in the name gets the date value (a date is basically a double value in VBA) by converting the name into the date. If the name cannot be converted to a date, the value will be so that the sheet will be sorted to the end (but before the version sheet).
Function getSortNumber(ws As Worksheet) As Double
Const MaxNumber = 100000
If ws.Name = "Initial" Then
' Sort Initial to the beginning
getSortNumber = 0
ElseIf ws.Name = "Version" Then
' Sort Version to the end
getSortNumber = MaxNumber + ws.Parent.Sheets.Count
Else
' Create real date fom name
Dim d As Date, tokens() As String
tokens = Split(ws.Name, "-")
On Error Resume Next
d = DateSerial(Val(tokens(2)), Val(tokens(1)), Val(tokens(0)))
On Error GoTo 0
If d = 0 Then
' Failed to convert to date, sort to end
getSortNumber = MaxNumber + ws.Index
Else
' Sort according to the date value
getSortNumber = CDbl(d)
End If
End If
End Function
You can adapt the function easily if your needs changed (eg date format, or you can have extra text with the date, or you want to sort the version sheet to the beginning, or you have additional sheets with different names...). The sort function itself will not change at all, only the comparison logic.
Now all you have to do is change the line in the sort routine:
If wb.Worksheets(j).Name < wb.Worksheets(i).Name Then
to
If getSortNumber(wb.Worksheets(j)) < getSortNumber(wb.Worksheets(i)) Then
The general approach of converting the sheet names (that, hopefully, look like dates) to actual date serial numbers, and sorting those has been answered. But there is a a bit more to it than other answers show.
If your sheet names are user entered, you should handle a bit of variability
No need to reinvent Date Conversion, use whats already in Excel/VBA. But you need to define what year a 2 digit number represents, specifically which century it's in.
Note: How DateSerial interprets 2 digit dates is a bit complex. Refer to the docs for details
Decide what you want to do with sheets whose names cannot be converted to valid dates. Options include
Clean them up. eg
remove excess white space
allow for suffixes (times?)
alternate delimiters
other date forms (eg 1 Oct 2020)
etc
Aborting
Delete them
Move them to a defined location
Move them to another workbook
Prompt user for a new valid name
Generate a new valid name in the code
etc
Once the date serial numbers are created, you sort that data. Many options exist
Use the Dynamic Array function SORT, if you have it
If you don't, there are many Array Sort algorithms and implementations available for VBA
Examples 1 2
Use a data structure that supports Sorting. Example System.Collections.ArrayList 1
Dump the data onto a sheet and use Excel Sort
Once you have the sorted data, move the sheets into place. Note: another answer provide a nested For loop. This executes in order n^2 (n = number of sheets) May not matter for a smallish number of sheets, but will get much slower as the number of sheets increases. But it's easily avoided, see the code below.
Suggested methodoligy, including comments on what to change to suit your needs. Run this after the user has inserted a new sheet.
Sub SortSheets()
Dim ws As Worksheet
Dim wb As Workbook
Dim idx As Long
Dim SheetNames As Variant
Set wb = ThisWorkbook ' or specify the book you want
' Validate book contents
On Error Resume Next
Set ws = wb.Worksheets("Initial")
On Error GoTo 0
If ws Is Nothing Then
' Initial Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> 1 Then
' Move it to first
ws.Move Before:=wb.Worksheets(1)
End If
On Error Resume Next
Set ws = wb.Worksheets("Version")
On Error GoTo 0
If ws Is Nothing Then
' Version Doesn't exist. What now?
Exit Sub
End If
If ws.Index <> wb.Worksheets.Count Then
' Move it to last
ws.Move After:=wb.Worksheets(wb.Worksheets.Count)
End If
' For each sheet between first and last,
' Convert Name to a dateSerial
' Handle any invalidly named sheets
ReDim SheetNames(2 To wb.Worksheets.Count - 1, 1 To 2)
For idx = 2 To wb.Worksheets.Count - 1
Set ws = wb.Worksheets(idx)
On Error Resume Next
' convert sheet name to date
SheetNames(idx, 1) = getDate(ws.Name)
On Error GoTo 0
If IsEmpty(SheetNames(idx, 1)) Then
' Invalid Sheet Name format. What Now?
' eg move it to the end (before Version)
SheetNames(idx, 1) = 3000000
' change to handle as you require, eg Delete it, Prompt user for a new name, etc
End If
SheetNames(idx, 2) = ws.Name
Next
' Sort on date using Dynamic Array Function SORT
SheetNames = Application.Sort(SheetNames)
' If SORT is not available, there are many Array Sort algorithms and implementations available
' Move sheets into position
' SheetNames is a 2D array of the DateSerial numbers and actual sheet names, sorted in the order we want them in the book
' Loop through the array lowest to highest,
' Get a reference to the sheet by name
' Move it to its required position (if it's not already there)
For idx = 1 To UBound(SheetNames, 1)
Set ws = wb.Worksheets(SheetNames(idx, 2))
If ws.Index <> idx + 1 Then
ws.Move After:=wb.Worksheets(idx)
End If
Next
End Sub
Function getDate(DateStr As String, Optional Delim As String = "-") As Long
' Cleanup sheet name
' Add or remove cleaning to suit your needs
' reduce multiple space sequences to single spaces
DateStr = Application.WorksheetFunction.Trim(DateStr)
' remove spaces aroung delimiter
DateStr = Replace$(DateStr, " " & Delim, Delim) '
DateStr = Replace$(DateStr, Delim & " ", Delim)
' replace any remaining spaces with delimiter (needed to make Val() work as desired)
DateStr = Replace$(DateStr, " ", Delim)
' Create real date from name
Dim d As Long, Segments() As String
Segments = Split(DateStr, Delim)
If UBound(Segments) < 2 Then
' not enough segments
d = 0
ElseIf UBound(Segments) > 2 Then
' too many segments. What Now?
' do nothing if it's acceptable to ignore anything after the date
Else
' Segment(0) is first part, assumed to be Day
' Segment(1) is second part, assumed to be Month
' Segment(2) is third part, assumed to be Year
' assume 2 digit dates are 2000's. Change to suit your needs
' Note: relying on DateSerial to convert 2 digit dates may give unexpected results
' as what you get depends on Excel version and local settings
If Len(Segments(2)) <= 2 Then Segments(2) = "20" & Format$(Segments(2), "00")
On Error Resume Next
d = CLng(DateSerial(CInt(Val(Segments(2))), CInt(Segments(1)), CInt(Segments(0))))
On Error GoTo 0
End If
If d = 0 Then
' Could not convert to date. Let calling routine decide what to do now
Err.Raise 1, "getDate", "Invalid Date string"
Else
' return date value
getDate = d
End If
End Function
Insert Date Worksheet
Note the following in two-digit year notation:
01/01/30 ... 01/01/1930
12/31/99 ... 12/31/1999
01/01/00 ... 01/01/2000
12/31/29 ... 12/31/2029
Some complications are present due to:
Sub Test1()
Debug.Print DateSerial(111, 22, 33) ' Result '11/02/112'
Debug.Print DateSerial(21, 2, 30) ' Result ' 03/02/2021
End Sub
The following will not sort any previously added worksheets. It will just insert the new worksheet in the right spot i.e. before the first worksheet with a greater date than the date supplied, or before the last worksheet (if no greater date).
Option Explicit
Sub InsertDateWorksheet()
' Needs 'RefWorksheet', 'InputDateText', 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InsertDateWorksheet"
Const First As String = "Initial"
Const Last As String = "Version"
Const Delimiter As String = "-"
Dim wb As Workbook: Set wb = ThisWorkbook
' First Worksheet
Dim fws As Worksheet: Set fws = RefWorksheet(wb, First, True)
If fws Is Nothing Then Exit Sub
If Not fws Is wb.Sheets(1) Then
fws.Move Before:=wb.Sheets(1)
End If
' Last Worksheet
Dim lws As Worksheet: Set lws = RefWorksheet(wb, Last, True)
If lws Is Nothing Then Exit Sub
Dim shCount As Long: shCount = wb.Sheets.Count
If Not lws Is wb.Sheets(shCount) Then
lws.Move After:=wb.Sheets(shCount)
End If
Dim NewDate As Date: NewDate = InputDateText(True)
If NewDate = 0 Then Exit Sub
Dim NewDateString As String: NewDateString = CStr(Day(NewDate)) _
& Delimiter & CStr(Month(NewDate)) & Delimiter _
& Right(CStr(Year(NewDate)), 2)
Dim nws As Worksheet: Set nws = RefWorksheet(wb, NewDateString)
If Not nws Is Nothing Then
MsgBox "The worksheet '" & NewDateString & "' already exists.", _
vbCritical, ProcName
Exit Sub
End If
Dim ws As Worksheet
Dim wsDate As Date
For Each ws In wb.Worksheets
Select Case ws.Name
Case First
Case Last
Exit For
Case Else
wsDate = GetTwoDigitYearDate(ws.Name, Delimiter)
If NewDate < wsDate Then
Exit For
End If
End Select
Next ws
Worksheets.Add(Before:=ws).Name = NewDateString
MsgBox "Worksheet '" & NewDateString & "' added.", vbInformation, ProcName
End Sub
Function RefWorksheet( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
Optional ByVal DoWriteMessage As Boolean = False) _
As Worksheet
Const ProcName As String = "RefWorksheet"
On Error Resume Next
Set RefWorksheet = wb.Worksheets(WorksheetName)
On Error GoTo 0
If DoWriteMessage Then
If RefWorksheet Is Nothing Then
MsgBox "Worksheet '" & WorksheetName & "' not found.", _
vbCritical, ProcName
Exit Function
End If
End If
End Function
Function InputDateText( _
Optional ByVal DoWriteMessage As Boolean = False) _
As Date
' Needs 'GetTwoDigitYearDate' and 'IsLeapYear'.
Const ProcName As String = "InputDateText"
Const InputFormat As String = "d-m-yy"
Const nTitle As String = "Input Date Text"
Dim nPrompt As String
nPrompt = "Please enter a date in '" & InputFormat & "' format..."
Dim nDefault As String: nDefault = Format(Date, InputFormat)
Dim NewDateString As Variant: NewDateString = Application.InputBox( _
nPrompt, nTitle, nDefault, , , , , 2)
If NewDateString = False Then
MsgBox "You canceled.", vbExclamation, ProcName
Exit Function
End If
InputDateText = GetTwoDigitYearDate(NewDateString, "-")
If DoWriteMessage Then
If InputDateText = 0 Then
MsgBox "The string '" & NewDateString & "' is not valid.", _
vbCritical, ProcName
End If
End If
End Function
Function GetTwoDigitYearDate( _
ByVal DateString As String, _
Optional ByVal Delimiter As String = "-") _
As Date
' Needs 'IsLeapYear'.
On Error GoTo ClearError
Dim ArrDate() As String: ArrDate = Split(DateString, Delimiter)
Dim nYear As Long: nYear = CLng(ArrDate(2))
Select Case nYear
Case Is < 0, Is > 99
Exit Function
Case Else
nYear = IIf(nYear > 29, nYear + 1900, nYear + 2000)
End Select
Dim nMonth As Long: nMonth = CLng(ArrDate(1))
Select Case nMonth
Case Is < 1, Is > 12
Exit Function
End Select
Dim nDay As Long: nDay = CLng(ArrDate(0))
Select Case nDay
Case Is < 1, Is > 31
Exit Function
End Select
Select Case nMonth
Case 4, 6, 9, 11
If nDay = 31 Then Exit Function
Case 2
If nDay > 29 Then Exit Function
If nDay = 29 Then
If Not IsLeapYear(nYear) Then Exit Function
End If
End Select
GetTwoDigitYearDate = DateSerial(nYear, nMonth, nDay)
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
Function IsLeapYear( _
TestYear As Long) _
As Boolean
If TestYear Mod 4 = 0 Then
If TestYear Mod 100 = 0 Then
If TestYear Mod 400 = 0 Then
' Accounting for e.g. years 2000, 2400, 2800...8800, 9200, 9600.
IsLeapYear = True
'Else
' Accounting for e.g. years 2100, 2200, 2300...9700, 9800, 9900.
'isLeapYear = False
End If
Else
' Accounting for e.g. years 1904, 1908, 1912...1988, 1992, 1996.
IsLeapYear = True
End If
'Else
' Accounting for e.g. years 1901, 1902, 1903...1997, 1998, 1999.
'isLeapYear = False
End If
End Function
I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.
Public Function ImportData()
Dim resultWorkbook As Workbook
Dim curWorkbook As Workbook
Dim importsheet As Worksheet
Dim debugsheet As Worksheet
Dim spgsheet As Worksheet
Dim totalposts As Integer
Dim year As String
Dim month As String
Dim week As String
Dim Hospital As String
Dim varType As String
Dim numrows As Integer
Dim Rng As Range
Dim colavg As String
Dim timer As String
Dim varKey As String
year = ImportWindow.ddYear.value
month = ImportWindow.ddMonth.value
week = "1"
varType = ImportWindow.ddType.value
Hospital = ImportWindow.txtHospital.value
Set debugsheet = ActiveWorkbook.Sheets("Data")
Set spgsheet = ActiveWorkbook.Sheets("Spørgsmål")
Set depsheet = ActiveWorkbook.Sheets("Enheder")
Set resultWorkbook = OpenWorkbook()
setResultColVars debugsheet
'set sheets
Set importsheet = resultWorkbook.Sheets("Dataset")
numrows = debugsheet.UsedRange.Rows.Count
'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
Dim DepColumn
Dim aCell
DepColumn = importsheet.UsedRange.Find("afdeling").column
'sort importsheet to allow meaningfull row calculations
Set aCell = importsheet.UsedRange.Columns(DepColumn)
importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim tempRange As Range
Dim SecColumn
Dim secRange As Range
'find row ranges for departments
Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**
For Each c In depsheet.UsedRange.Columns(1).Cells
splStr = Split(c.value, "_")
If UBound(splStr) = -1 Then
ElseIf UBound(splStr) = 0 Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
End If
Next
Application.ScreenUpdating = True
' go through columns to get total scores
totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)
resultWorkbook.Close Saved = True
ResultsWindow.lblPoster.Caption = totalposts
ImportWindow.Hide
ResultsWindow.Show
Else
MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datasæt"
End If
End Function
Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function
'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
Dim tempi
tempi = numrows + totalposts + 1
Set Rng = varRange.Columns(i)
With Application.WorksheetFunction
'make sure that the values can calculate
If (.CountIf(Rng, "<3") > 0) Then
colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
insert = True
Else
insert = False
End If
End With
'key is the variable
varKey = importsheet.Cells(1, i)
'only add datarow if the data matches a spg, and the datarow is not actually a department
If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
resultsheet.Cells(tempi, WyearCol).value = year
resultsheet.Cells(tempi, WmonthCol).value = month
resultsheet.Cells(tempi, WweekCol).value = "1"
resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
resultsheet.Cells(tempi, WdepnrCol).value = dep
resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
resultsheet.Cells(tempi, WjtypeCol).value = varType
resultsheet.Cells(tempi, WspgCol).value = varKey
resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,6,0)"
resultsheet.Cells(tempi, WtestCol).value = ""
resultsheet.Cells(tempi, Wsv1Col).value = colavg
resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
resultsheet.Cells(tempi, Wsv3Col).value = ""
resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,4,0)"
totalposts = totalposts + 1
End If
Next
End If
IterateColumns = totalposts
End Function
'Function that gets the workbook for import
Function OpenWorkbook()
Dim pathString As String
Dim resultWorkbook As Workbook
pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")
' check if it's already opened
For Each wb In Workbooks
If InStr(pathString, wb.Name) > 0 Then
Set resultWorkbook = wb
Exit For
End If
Next wb
If Not found Then
Set resultWorkbook = Workbooks.Open(pathString)
End If
Set OpenWorkbook = resultWorkbook
End Function
'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("År").column
WmonthCol = rsheet.UsedRange.Find("Måned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("spørgsmål").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function
Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
If (sortspg) Then
ResultsWindow.lstGenkendt.AddItem key
End If
sortSpgs = True
Else
If (sortspg) Then
ResultsWindow.lstUgenkendt.AddItem key
End If
sortSpgs = False
End If
End Function
Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function
Difficult to debug without the source files.
I see the following potential problems:
GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.
Generally, a few more "best practise remarks":
* Dim your variables with the correct types, same for returns of functions
* Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines
* In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read
Hope that helps a bit... mvh /P.
My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.
you could also try to write the usedrange in an array, work with it , and write it back if needed.
code example
dim MyArr() as Variant
redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value
'calculating with Myarray instead of ranges (faster)
usedrange.value=myarray 'writes changes back to the sheet/range
also, maybe you can use .match instead of .find, wich is faster.
with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match
the same thing works for range.find() , becoming application.find()...
save first your master workbook under a new name before making such a big change...
I would like to determine a time offset to GMT/UTC (including daylight saving time) for different countries at a specific date in VBA. Any ideas?
EDIT (from self-answer):
Thank you 0xA3. I quickly read-over the linked page. I assume that you can only get the offset to GMT for the local where windows is running:
ConvertLocalToGMT
DaylightTime
GetLocalTimeFromGMT
LocalOffsetFromGMT
SystemTimeToVBTime
LocalOffsetFromGMT
In Java you can do the following:
TimeZone bucharestTimeZone = TimeZone.getTimeZone("Europe/Bucharest");
bucharestTimeZone.getOffset(new Date().getTime());
Calendar nowInBucharest = Calendar.getInstance(TimeZone.getTimeZone("Europe/Bucharest"));
nowInBucharest.setTime(new Date());
System.out.println("Bucharest: " + nowInBucharest.get(Calendar.HOUR) + ":" + nowInBucharest.get(Calendar.MINUTE));
This means I can get the offset for different countries (timezones) and I thus can also get the actual time lets say in bucharest. Can I do this in VBA?
VBA doesn't offer functions to do that, but the Windows API does. Luckily you can use all those functionality from VBA as well. This page describes how to do it: Time Zones & Daylight Savings Time
Edit: Added Code
For the posterity sake, I've added the complete code from Guru Chip's page, as usable in 32-bit Office VBA. (64-bit modification here)
Option Explicit
Option Compare Text
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modTimeZones
' By Chip Pearson, used with permission from www.cpearson.com
' Date: 2-April-2008
' Page Specific URL: www.cpearson.com/Excel/TimeZoneAndDaylightTime.aspx
'
' This module contains functions related to time zones and GMT times.
' Terms:
' -------------------------
' GMT = Greenwich Mean Time. Many applications use the term
' UTC (Universal Coordinated Time). GMT and UTC are
' interchangable in meaning,
' Local Time = The local "wall clock" time of day, that time that
' you would set a clock to.
' DST = Daylight Savings Time
' Functions In This Module:
' -------------------------
' ConvertLocalToGMT
' Converts a local time to GMT. Optionally adjusts for DST.
' DaylightTime
' Returns a value indicating (1) DST is in effect, (2) DST is
' not in effect, or (3) Windows cannot determine whether DST is
' in effect.
' GetLocalTimeFromGMT
' Converts a GMT Time to a Local Time, optionally adjusting for DST.
' LocalOffsetFromGMT
' Returns the number of hours/minutes between the local time &GMT,
' optionally adjusting for DST.
' SystemTimeToVBTime
' Converts a SYSTEMTIME structure to a valid VB/VBA date.
' LocalOffsetFromGMT
' Returns the number of minutes or hours that are to be added to
' the local time to get GMT. Optionally adjusts for DST.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Required Types
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To 31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To 31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Public Enum TIME_ZONE
TIME_ZONE_ID_INVALID = 0
TIME_ZONE_STANDARD = 1
TIME_ZONE_DAYLIGHT = 2
End Enum
' Required Windows API Declares
Private Declare Function GetTimeZoneInformation Lib "kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
Private Declare Sub GetSystemTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME)
Function ConvertLocalToGMT(Optional LocalTime As Date, _
Optional AdjustForDST As Boolean = False) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ConvertLocalToGMT
' This converts a local time to GMT. If LocalTime is present, that local
' time is converted to GMT. If LocalTime is omitted, the current time is
' converted from local to GMT. If AdjustForDST is Fasle, no adjustments
' are made to accomodate DST. If AdjustForDST is True, and DST is
' in effect, the time is adjusted for DST by adding
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim T As Date
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
Dim GMT As Date
If LocalTime <= 0 Then
T = Now
Else
T = LocalTime
End If
DST = GetTimeZoneInformation(TZI)
If AdjustForDST = True Then
GMT = T + TimeSerial(0, TZI.Bias, 0) + _
IIf(DST=TIME_ZONE_DAYLIGHT,TimeSerial(0, TZI.DaylightBias,0),0)
Else
GMT = T + TimeSerial(0, TZI.Bias, 0)
End If
ConvertLocalToGMT = GMT
End Function
Function GetLocalTimeFromGMT(Optional StartTime As Date) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetLocalTimeFromGMT
' This returns the Local Time from a GMT time. If StartDate is present and
' greater than 0, it is assumed to be the GMT from which we will calculate
' Local Time. If StartTime is 0 or omitted, it is assumed to be the GMT
' local time.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim GMT As Date
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
Dim LocalTime As Date
If StartTime <= 0 Then
GMT = Now
Else
GMT = StartTime
End If
DST = GetTimeZoneInformation(TZI)
LocalTime = GMT - TimeSerial(0, TZI.Bias, 0) + _
IIf(DST = TIME_ZONE_DAYLIGHT, TimeSerial(1, 0, 0), 0)
GetLocalTimeFromGMT = LocalTime
End Function
Function SystemTimeToVBTime(SysTime As SYSTEMTIME) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SystemTimeToVBTime
' This converts a SYSTEMTIME structure to a VB/VBA date value.
' It assumes SysTime is valid -- no error checking is done.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With SysTime
SystemTimeToVBTime = DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond)
End With
End Function
Function LocalOffsetFromGMT(Optional AsHours As Boolean = False, _
Optional AdjustForDST As Boolean = False) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LocalOffsetFromGMT
' This returns the amount of time in minutes (if AsHours is omitted or
' false) or hours (if AsHours is True) that should be added to the
' local time to get GMT. If AdjustForDST is missing or false,
' the unmodified difference is returned. (e.g., Kansas City to London
' is 6 hours normally, 5 hours during DST. If AdjustForDST is False,
' the resultif 6 hours. If AdjustForDST is True, the result is 5 hours
' if DST is in effect.)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TBias As Long
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
DST = GetTimeZoneInformation(TZI)
If DST = TIME_ZONE_DAYLIGHT Then
If AdjustForDST = True Then
TBias = TZI.Bias + TZI.DaylightBias
Else
TBias = TZI.Bias
End If
Else
TBias = TZI.Bias
End If
If AsHours = True Then
TBias = TBias / 60
End If
LocalOffsetFromGMT = TBias
End Function
Function DaylightTime() As TIME_ZONE
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DaylightTime
' Returns a value indicating whether the current date is
' in Daylight Time, Standard Time, or that Windows cannot
' deterimine the time status. The result is a member or
' the TIME_ZONE enum.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
DST = GetTimeZoneInformation(TZI)
DaylightTime = DST
End Function
Please be aware of little trap in the solution.
The GetTimeZoneInformation() call returns DST info about the current time, but the converted date might be from the period with the different DST setting - thus converting January date in August would apply the current Bias, thus yielding the GMT date 1 hour less than the correct one (SystemTimeToTzSpecificLocalTime seems to be a better fit - untested yet)
The same applies when the date is from another year - when DST rules might have been different. GetTimeZoneInformationForYear should handle changes in different years. I'll put a code sample here once completed.
It also seems Windows does not provide a reliable way to get 3 letter abbreviation of the timezone (Excel 2013 supports zzz in Format() - not tested).
Edit 16.04.2015: IntArrayToString() removed as it is already present in modWorksheetFunctions.bas referenced in below mentioned cpearson.com articles.
Adding code to convert using timezone active at the time of the converted date (this issue is not addressed on cpearson.com). Error handling is not included for brevity.
Private Type DYNAMIC_TIME_ZONE_INFORMATION_VB
Bias As Long
StandardName As String
StandardDate As Date
StandardBias As Long
DaylightName As String
DaylightDate As Date
DaylightBias As Long
TimeZoneKeyName As String
DynamicDaylightTimeDisabled As Long
End Type
Private Declare Function GetTimeZoneInformationForYear Lib "kernel32" ( _
wYear As Integer, _
lpDynamicTimeZoneInformation As DYNAMIC_TIME_ZONE_INFORMATION, _
lpTimeZoneInformation As TIME_ZONE_INFORMATION _
) As Long
Private Declare Function GetDynamicTimeZoneInformation Lib "kernel32" ( _
pTimeZoneInformation As DYNAMIC_TIME_ZONE_INFORMATION _
) As Long
Private Declare Function TzSpecificLocalTimeToSystemTimeEx Lib "kernel32" ( _
lpDynamicTimeZoneInformation As DYNAMIC_TIME_ZONE_INFORMATION, _
lpLocalTime As SYSTEMTIME, _
lpUniversalTime As SYSTEMTIME _
) As Long
Function LocalSerialTimeToGmt(lpDateLocal As Date) As Date
Dim retval As Boolean, lpDateGmt As Date, lpSystemTimeLocal As SYSTEMTIME, lpSystemTimeGmt As SYSTEMTIME
Dim lpDTZI As DYNAMIC_TIME_ZONE_INFORMATION
retval = SerialTimeToSystemTime(lpDateLocal, lpSystemTimeLocal)
retval = GetDynamicTimeZoneInformation(lpDTZI)
retval = TzSpecificLocalTimeToSystemTimeEx(lpDTZI, lpSystemTimeLocal, lpSystemTimeGmt)
lpDateGmt = SystemTimeToSerialTime(lpSystemTimeGmt)
LocalSerialTimeToGmt = lpDateGmt
End Function
There are 2 ways to achieve offset:
subtract local date and converted gmt date:
offset = (lpDateLocal - lpDateGmt)*24*60
get TZI for specific year and calculate:
dst = GetTimeZoneInformationForYear(Year(lpDateLocal), lpDTZI, lpTZI)
offset = lpTZI.Bias + IIf(lpDateLocal >= SystemTimeToSerialTime(lpTZI.DaylightDate) And lpDateLocal < SystemTimeToSerialTime(lpTZI.StandardDate), lpTZI.DaylightBias, lpTZI.StandardBias)
Caveat: For some reason, values populated in lpTZI here do not contain the year information, so you need to set the year in lpTZI.DaylightDate and lpTZI.StandardDate.
Here is the code that is referenced in the answer by 0xA3. I had to change the declare statements to allow it run properly in Office 64bit but I haven't been able to test again in Office 32bit. For my use I was trying to create ISO 8601 dates with timezone information. So i used this function for that.
Public Function ConvertToIsoTime(myDate As Date, includeTimezone As Boolean) As String
If Not includeTimezone Then
ConvertToIsoTime = Format(myDate, "yyyy-mm-ddThh:mm:ss")
Else
Dim minOffsetLong As Long
Dim hourOffset As Integer
Dim minOffset As Integer
Dim formatStr As String
Dim hourOffsetStr As String
minOffsetLong = LocalOffsetFromGMT(False, True) * -1
hourOffset = minOffsetLong \ 60
minOffset = minOffsetLong Mod 60
If hourOffset >= 0 Then
hourOffsetStr = "+" + CStr(Format(hourOffset, "00"))
Else
hourOffsetStr = CStr(Format(hourOffset, "00"))
End If
formatStr = "yyyy-mm-ddThh:mm:ss" + hourOffsetStr + ":" + CStr(Format(minOffset, "00"))
ConvertToIsoTime = Format(myDate, formatStr)
End If
End Function
The code below came from http://www.cpearson.com/excel/TimeZoneAndDaylightTime.aspx
Option Explicit
Option Compare Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modTimeZones
' By Chip Pearson, chip#cpearson.com, www.cpearson.com
' Date: 2-April-2008
' Page Specific URL: www.cpearson.com/Excel/TimeZoneAndDaylightTime.aspx
'
' This module contains functions related to time zones and GMT times.
' Terms:
' -------------------------
' GMT = Greenwich Mean Time. Many applications use the term
' UTC (Universal Coordinated Time). GMT and UTC are
' interchangable in meaning,
' Local Time = The local "wall clock" time of day, that time that
' you would set a clock to.
' DST = Daylight Savings Time
' Functions In This Module:
' -------------------------
' ConvertLocalToGMT
' Converts a local time to GMT. Optionally adjusts for DST.
' DaylightTime
' Returns a value indicating (1) DST is in effect, (2) DST is
' not in effect, or (3) Windows cannot determine whether DST is
' in effect.
' GetLocalTimeFromGMT
' Converts a GMT Time to a Local Time, optionally adjusting for DST.
' LocalOffsetFromGMT
' Returns the number of hours or minutes between the local time and GMT,
' optionally adjusting for DST.
' SystemTimeToVBTime
' Converts a SYSTEMTIME structure to a valid VB/VBA date.
' LocalOffsetFromGMT
' Returns the number of minutes or hours that are to be added to
' the local time to get GMT. Optionally adjusts for DST.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Required Types
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Type TIME_ZONE_INFORMATION
Bias As Long
StandardName(0 To 31) As Integer
StandardDate As SYSTEMTIME
StandardBias As Long
DaylightName(0 To 31) As Integer
DaylightDate As SYSTEMTIME
DaylightBias As Long
End Type
Public Enum TIME_ZONE
TIME_ZONE_ID_INVALID = 0
TIME_ZONE_STANDARD = 1
TIME_ZONE_DAYLIGHT = 2
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' Required Windows API Declares
'''''''''''''''''''''''''''''''''''''''''''''''''''''
#If VBA7 Then
Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
#Else
Private Declare Function GetTimeZoneInformation Lib "kernel32" _
(lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Sub GetSystemTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME)
#Else
Private Declare Sub GetSystemTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME)
#End If
Function ConvertLocalToGMT(Optional LocalTime As Date, _
Optional AdjustForDST As Boolean = False) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ConvertLocalToGMT
' This converts a local time to GMT. If LocalTime is present, that local
' time is converted to GMT. If LocalTime is omitted, the current time is
' converted from local to GMT. If AdjustForDST is Fasle, no adjustments
' are made to accomodate DST. If AdjustForDST is True, and DST is
' in effect, the time is adjusted for DST by adding
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim T As Date
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
Dim GMT As Date
If LocalTime <= 0 Then
T = Now
Else
T = LocalTime
End If
DST = GetTimeZoneInformation(TZI)
If AdjustForDST = True Then
GMT = T + TimeSerial(0, TZI.Bias, 0) + _
IIf(DST = TIME_ZONE_DAYLIGHT, TimeSerial(0, TZI.DaylightBias, 0), 0)
Else
GMT = T + TimeSerial(0, TZI.Bias, 0)
End If
ConvertLocalToGMT = GMT
End Function
Function GetLocalTimeFromGMT(Optional StartTime As Date) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetLocalTimeFromGMT
' This returns the Local Time from a GMT time. If StartDate is present and
' greater than 0, it is assumed to be the GMT from which we will calculate
' Local Time. If StartTime is 0 or omitted, it is assumed to be the GMT
' local time.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim GMT As Date
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
Dim LocalTime As Date
If StartTime <= 0 Then
GMT = Now
Else
GMT = StartTime
End If
DST = GetTimeZoneInformation(TZI)
LocalTime = GMT - TimeSerial(0, TZI.Bias, 0) + _
IIf(DST = TIME_ZONE_DAYLIGHT, TimeSerial(1, 0, 0), 0)
GetLocalTimeFromGMT = LocalTime
End Function
Function SystemTimeToVBTime(SysTime As SYSTEMTIME) As Date
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SystemTimeToVBTime
' This converts a SYSTEMTIME structure to a VB/VBA date value.
' It assumes SysTime is valid -- no error checking is done.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With SysTime
SystemTimeToVBTime = DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond)
End With
End Function
Function LocalOffsetFromGMT(Optional AsHours As Boolean = False, _
Optional AdjustForDST As Boolean = False) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' LocalOffsetFromGMT
' This returns the amount of time in minutes (if AsHours is omitted or
' false) or hours (if AsHours is True) that should be added to the
' local time to get GMT. If AdjustForDST is missing or false,
' the unmodified difference is returned. (e.g., Kansas City to London
' is 6 hours normally, 5 hours during DST. If AdjustForDST is False,
' the resultif 6 hours. If AdjustForDST is True, the result is 5 hours
' if DST is in effect.)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TBias As Long
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
DST = GetTimeZoneInformation(TZI)
If DST = TIME_ZONE_DAYLIGHT Then
If AdjustForDST = True Then
TBias = TZI.Bias + TZI.DaylightBias
Else
TBias = TZI.Bias
End If
Else
TBias = TZI.Bias
End If
If AsHours = True Then
TBias = TBias / 60
End If
LocalOffsetFromGMT = TBias
End Function
Function DaylightTime() As TIME_ZONE
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DaylightTime
' Returns a value indicating whether the current date is
' in Daylight Time, Standard Time, or that Windows cannot
' deterimine the time status. The result is a member or
' the TIME_ZONE enum.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TZI As TIME_ZONE_INFORMATION
Dim DST As TIME_ZONE
DST = GetTimeZoneInformation(TZI)
DaylightTime = DST
End Function
I recommend to create an Outlook object and use the in-built method ConvertTime: https://msdn.microsoft.com/VBA/Outlook-VBA/articles/timezones-converttime-method-outlook
Super easy, super save and just a few lines of code
This example converts the inputTime from UTC to CET:
As a source/destination time zone you can use all time zones you can find
in your registry under:
HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Time Zones/
Dim OutlookApp As Object
Dim TZones As TimeZones
Dim convertedTime As Date
Dim inputTime As Date
Dim sourceTZ As TimeZone
Dim destTZ As TimeZone
Dim secNum as Integer
Set OutlookApp = CreateObject("Outlook.Application")
Set TZones = OutlookApp.TimeZones
Set sourceTZ = TZones.Item("UTC")
Set destTZ = TZones.Item("W. Europe Standard Time")
inputTime = Now
Debug.Print "GMT: " & inputTime
'' the outlook rounds the seconds to the nearest minute
'' thus, we store the seconds, convert the truncated time and add them later
secNum = Second(inputTime)
inputTime = DateAdd("s",-secNum, inputTime)
convertedTime = TZones.ConvertTime(inputTime, sourceTZ, destTZ)
convertedTime = DateAdd("s",secNum, convertedTime)
Debug.Print "CET: " & convertedTime
PS: if you often have to use the method, I recommend to declare the Outlook object outside of your sub/function. Create it once and keep it alive.
Based on Julian Hess excellent recommendation to use Outlook capabilities, I have build this module, which works with Access and Excel.
Option Explicit
'mTimeZones by Patrick Honorez --- www.idevlop.com
'with the precious help of Julian Hess https://stackoverflow.com/a/45510712/78522
'You can reuse but please let all the original comments including this one.
'This modules uses late binding and therefore should not require an explicit reference to Outlook,
'however Outlook must be properly installed and configured on the machine using this module
'Module works with Excel and Access
Private oOutl As Object 'keep Outlook reference active, to save time in recurring calls
Private oOutlTimeZones As Object 'keep Outlook reference active, to save time in recurring calls
' seems to drop the reference if use previous scheme of returning boolean
' returning the actual object is more correct in any case
Private Function GetOutlookTimeZones() As Object
If oOutl Is Nothing Or oOutlTimeZones Is Nothing Then
Debug.Print "~"
On Error Resume Next
Err.Clear
Set oOutl = GetObject(, "Outlook.Application")
If Err.Number Then
Err.Clear
Set oOutl = CreateObject("Outlook.Application")
End If
Set oOutlTimeZones = oOutl.TimeZones
End If
Set GetOutlookTimeZones = oOutlTimeZones
On Error GoTo 0
End Function
Function ConvertTime(DT As Date, Optional TZfrom As String = "Central Standard Time", _
Optional TZto As String = "W. Europe Standard Time") As Date
'convert datetime with hour from Source time zone to Target time zone
'valid Source & Target time zones can be found in your registry under: HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Time Zones/
'this version using Outlook, properly handles Dailight Saving Times, including for past and future dates
'it includes a fix for the fact that ConvertTime seems to strip the seconds
'krammy85 2019-01-25 Edit: Outlook rounds minutes when it strips seconds, so modified code to strip seconds (without rounding) prior to running Outlook's ConvertTime.
Dim sourceTZ As Object
Dim destTZ As Object
Dim seconds As Single
Dim DT_SecondsStripped As Date
Dim oOutlTimeZones As Object: Set oOutlTimeZones = GetOutlookTimeZones()
If Not (oOutlTimeZones Is Nothing) Then
'fix for ConvertTime stripping the seconds
seconds = Second(DT) / 86400 'save the seconds as DateTime (86400 = 24*60*60)
DT_SecondsStripped = DT - seconds
Set sourceTZ = oOutlTimeZones.Item(TZfrom)
Set destTZ = oOutlTimeZones.Item(TZto)
ConvertTime = oOutlTimeZones.ConvertTime(DT_SecondsStripped, sourceTZ, destTZ) + seconds 'add the stripped seconds
End If
End Function
' returns number of minutes ahead of UTC (positive number) or behind
Function GetOffsetAt(DT As Date, TZfrom As String) As Long
Dim utc_DT As Date: utc_DT = ConvertTime(DT, TZfrom, "UTC")
GetOffsetAt = DateDiff("n", utc_DT, DT)
End Function
Sub test_ConvertTime()
Dim t As Date: t = #8/23/2017 6:15:05 AM#
Debug.Print t, ConvertTime(t), Format(t - ConvertTime(t), "h")
Debug.Print t, ConvertTime(t, "Central Standard Time", "W. Europe Standard Time"), Format(t - ConvertTime(t), "h")
End Sub
Sub test_DumpTZs()
Dim TZ As Object: For Each TZ In GetOutlookTimeZones()
Debug.Print "TZ:", TZ.Id, TZ.Name
Next TZ
End Sub
While Outlook may provide a (slow) shortcut to the time zone information, you can go the direct route, but it takes a lot of code for a generic solution - much more than posted above and way too much to post here, partly because some information is localised.
A core function from my project VBA.Timezone-Windows is this:
' Required references:
' Windows Script Host Object Model
'
' 2019-12-14. Gustav Brock, Cactus Data ApS, CPH.
'
Private Function GetRegistryTimezoneItems( _
Optional ByRef DynamicDstYear As Integer) _
As TimezoneEntry()
Const Component As String = "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
Const DefKey As Long = HKeyLocalMachine
Const HKey As String = "HKLM"
Const SubKeyPath As String = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Time Zones"
Const DstPath As String = "Dynamic DST"
Const DisplayKey As String = "Display"
Const DaylightKey As String = "Dlt"
Const StandardKey As String = "Std"
Const MuiDisplayKey As String = "MUI_Display"
Const MuiDltKey As String = "MUI_Dlt"
Const MuiStdKey As String = "MUI_Std"
Const TziKey As String = "TZI"
Const FirstEntryKey As String = "FirstEntry"
Const LastEntryKey As String = "LastEntry"
Dim SWbemServices As Object
Dim WshShell As WshShell
Dim SubKey As Variant
Dim Names As Variant
Dim NameKeys As Variant
Dim Display As String
Dim DisplayUtc As String
Dim Name As Variant
Dim DstEntry As Variant
Dim Mui As Integer
Dim BiasLabel As String
Dim Bias As Long
Dim Locations As String
Dim TziDetails As Variant
Dim TzItems() As TimezoneEntry
Dim TzItem As TimezoneEntry
Dim Index As Long
Dim SubIndex As Long
Dim Value As String
Dim LBoundItems As Long
Dim UBoundItems As Long
Dim TziInformation As RegTziFormat
' The call is either for another year, or
' more than one day has passed since the last call.
Set SWbemServices = GetObject(Component)
Set WshShell = New WshShell
SWbemServices.EnumKey DefKey, SubKeyPath, Names
' Retrieve all timezones' base data.
LBoundItems = LBound(Names)
UBoundItems = UBound(Names)
ReDim TzItems(LBoundItems To UBoundItems)
For Index = LBound(Names) To UBound(Names)
' Assemble paths and look up key values.
SubKey = Names(Index)
' Invariant name of timezone.
TzItem.Name = SubKey
' MUI of the timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, MuiDisplayKey), "\")
Value = WshShell.RegRead(Name)
Mui = Val(Split(Value, ",")(1))
TzItem.Mui = Mui
' MUI of the standard timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, MuiStdKey), "\")
Value = WshShell.RegRead(Name)
Mui = Val(Split(Value, ",")(1))
TzItem.MuiStandard = Mui
' MUI of the DST timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, MuiDltKey), "\")
Value = WshShell.RegRead(Name)
Mui = Val(Split(Value, ",")(1))
TzItem.MuiDaylight = Mui
' Localised description of the timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, DisplayKey), "\")
Display = WshShell.RegRead(Name)
' Extract the first part, cleaned like "UTC+08:30".
DisplayUtc = Mid(Split(Display, ")", 2)(0) & "+00:00", 2, 9)
' Extract the offset part of first part, like "+08:30".
BiasLabel = Mid(Split(Display, ")", 2)(0) & "+00:00", 5, 6)
' Convert the offset part of the first part to a bias value (signed integer minutes).
Bias = -Val(Left(BiasLabel, 1) & Str(CDbl(CDate(Mid(BiasLabel, 2))) * 24 * 60))
' Extract the last part, holding the location(s).
Locations = Split(Display, " ", 2)(1)
TzItem.Bias = Bias
TzItem.Utc = DisplayUtc
TzItem.Locations = Locations
' Localised name of the standard timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, StandardKey), "\")
TzItem.ZoneStandard = WshShell.RegRead(Name)
' Localised name of the DST timezone.
Name = Join(Array(HKey, SubKeyPath, SubKey, DaylightKey), "\")
TzItem.ZoneDaylight = WshShell.RegRead(Name)
' TZI details.
SWbemServices.GetBinaryValue DefKey, Join(Array(SubKeyPath, SubKey), "\"), TziKey, TziDetails
FillRegTziFormat TziDetails, TziInformation
TzItem.Tzi = TziInformation
' Default Dynamic DST range.
TzItem.FirstEntry = Null
TzItem.LastEntry = Null
' Check for Dynamic DST info.
SWbemServices.EnumKey DefKey, Join(Array(SubKeyPath, SubKey), "\"), NameKeys
If IsArray(NameKeys) Then
' This timezone has subkeys. Check if Dynamic DST is present.
For SubIndex = LBound(NameKeys) To UBound(NameKeys)
If NameKeys(SubIndex) = DstPath Then
' Dynamic DST details found.
' Record first and last entry.
DstEntry = Join(Array(HKey, SubKeyPath, SubKey, DstPath, FirstEntryKey), "\")
Value = WshShell.RegRead(DstEntry)
TzItem.FirstEntry = Value
DstEntry = Join(Array(HKey, SubKeyPath, SubKey, DstPath, LastEntryKey), "\")
Value = WshShell.RegRead(DstEntry)
TzItem.LastEntry = Value
If DynamicDstYear >= TzItems(Index).FirstEntry And _
DynamicDstYear <= TzItems(Index).LastEntry Then
' Replace default TZI details with those from the dynamic DST.
DstEntry = Join(Array(SubKeyPath, SubKey, DstPath), "\")
SWbemServices.GetBinaryValue DefKey, Join(Array(SubKeyPath, SubKey), "\"), , CStr(DynamicDstYear), TziDetails
FillRegTziFormat TziDetails, TziInformation
TzItem.Tzi = TziInformation
Else
' Dynamic DST year was not found.
' Return current year.
DynamicDstYear = Year(Date)
End If
Exit For
End If
Next
End If
TzItems(Index) = TzItem
Next
GetRegistryTimezoneItems = TzItems
End Function
The project is supported by two articles:
Time Zones, Windows, and VBA - Part 1
Time Zones, Windows, and Microsoft Office - Part 2
including demos for Access and Excel.
Following are several functions that may be helpful, by comparing the returned values of IsDST with CheckDST and then adjusting the timezone date/time value accordingly. For example:
Dim SomeDateTime As Date 'Or Double
If IsDST Then
'Is currently DST, so add an hour if the date/time to be checked includes a standard-time date.
If Not CheckDST(SomeDateTime) Then SomeDateTime = SomeDateTime + TimeSerial(1, 0, 0)
Else
'Is not currently DST, so subtract an hour if the date/time to be checked includes a DST date.
If CheckDST(SomeDateTime) Then SomeDateTime = SomeDateTime - TimeSerial(1, 0, 0)
End If
CheckDST: Full-featured version. Returns True if Daylight Savings Time (or British Summer Time) applies to a specified date (in an optionally specified locale); otherwise returns False. Handles all US DST (and UK BST) system variations back to 1966, including President Nixon's "Emergency Daylight Saving Time Energy Conservation Act" of 1973 and Harold Wilson's "British Standard Time" experiment, October 27, 1968 to October 31, 1971.
CheckDST_UK1972: Simplified version. Returns True if the UK British Summer Time applies to a specified date, based on the BST system as it has been defined since 1972; otherwise returns False.
CheckDST_US2007: Simplified version. Returns True if the US Federal Daylight Savings Time applies to a specified date, based on the DST system established in 2007; otherwise returns False.
IsDST: Returns True if Daylight Savings Time is currently in effect (in the optionally specified locale); otherwise returns False.
NthDayOfWeekDate: Returns the Date of a specified Nth instance of a specified day-of-week in a specified month.
Option Explicit
Public Function CheckDST(ChkDate As Variant, Optional Locale As String = "USA") As Boolean
'
'Returns True if Daylight Savings Time applies to the specified date (in the optionally specified locale);
'otherwise returns False. Note that this function handles all dates back to 1/1/1966. For dates prior to
'that, an error message is displayed due to the difficulty of handling the highly inconsistent use of DST in
'prior years, across various locales.
'
'PARAMETERS:
'
' ChkDate The date to be checked for DST status. The data-type of the calling code's argument can
' be either Date or Double.
'
' Locale The geographic locale within which that locale's DST rules are to be applied. Values:
' "AZ" - DST hasn't applied to Arizona since 1967.
' "NN" - DST has applied in the Navajo Nation of northeastern Arizona.
' "AS" - DST has never applied in American Samoa (since WWII).
' "GU" - " Guam.
' "HI" - " Hawaii.
' "MP" - " Northern Marina Islands.
' "PR" - " Puerto Rico.
' "VI" - " Virgin Islands.
' "UK" - British Summer Time (BST) has been applied since the end of WWII (1945), from
' the last Sunday of March through the last Sunday of October, with one exception
' period from 1968 through 1971 in which it applied all year long (see details
' below).
' "USA" - All other states in the US, for which the federal DST rules have applied.
' Correctly handles President Nixon's "Emergency Daylight Saving Time Energy
' Conservation Act" of 1973.
'
'AUTHOR: Peter Straton
'
'*************************************************************************************************************
Const ThisFunction As String = "Function CheckDST()"
Const First As Integer = 1 'First instance in a month
Const Secnd As Integer = 2 'Second instance in a month
Const Last As Integer = 5 'Last instance: use max possible in a month
Const Mar As Integer = 3, Apr As Integer = 4, Oct As Integer = 10, Nov As Integer = 11
Const LawYearIdx As Integer = 0, StartInstanceIdx As Integer = 1, StartMonthIdx As Integer = 2, _
EndInstanceIdx As Integer = 3, EndMonthIdx As Integer = 4
Dim DateYear As Integer
Dim i As Integer
Dim StartInstance As Integer, StartMonth As Integer, EndInstance As Integer, EndMonth As Integer
Static US_StartEndSpecs As Variant
DateYear = Year(ChkDate)
If DateYear < 1966 Then
MsgBox "The specified date, " & ChkDate & ", is prior to this function's minimum date-year (1966) " & _
"which is necessary due to highly inconsistent use of DST in prior years, over various locales.", _
vbOKOnly + vbCritical, ThisFunction
Exit Function 'Return default: False
End If
Select Case Locale
Case "USA", "NN" 'Check these cases first, for execution efficiency and locale-logic shortcut
If ChkDate >= DateValue("1/6/1974") And ChkDate < DateValue("10/26/1975") Then
'Non-algorithmic case: On January 4, 1974, President Nixon signed the Emergency Daylight Saving Time
'Energy Conservation Act of 1973. Beginning on January 6, 1974, clocks were set ahead. On October 5,
'1974, Congress amended the Act, and Standard Time returned on October 27, 1974. Daylight Saving Time
'resumed on February 23, 1975 and ended on October 26, 1975.
'
'NOTE: Arizona was exempted.
If ChkDate >= DateValue("1/6/1974") And ChkDate < DateValue("10/27/1975") Or _
ChkDate >= DateValue("2/23/1975") And ChkDate < DateValue("10/26/1975") Then
CheckDST = True
Exit Function
End If
'Else
'Continue with DST calculation below...
End If
Case "UK" 'Check this case next, for execution efficiency and locale-logic shortcut
If ChkDate >= DateValue("10/27/1968") And ChkDate < DateValue("10/31/1971") Then
'Non-algorithmic case: The Harold Wilson government adopted "British Standard Time" (actually GMT+1,
'equivalent to DST) *throughout* the year. This took place between October 27, 1968 and October 31,
'1971 when there was a reversion back to the previous arrangement.
CheckDST = True
Exit Function 'Return default: False
'Else
'Continue with DST calculation below...
End If
StartInstance = Last: StartMonth = Mar 'Last Sunday of March
EndInstance = Last: EndMonth = Oct 'Last Sunday of October
Case "AZ"
If DateYear > 1967 Then Exit Function 'Hasn't participated in DST since 1967; return default: False
Case "AS", "GU", "HI", "MP", "PR", "VI"
Exit Function 'None of these have participated in DST (since WWII); return default: False
Case Else
MsgBox "Unknown Locale specification: """ & Locale & """", vbOKOnly + vbCritical, ThisFunction
End Select
If StartInstance = 0 Then '(If not defined above)
'If necessary, (re)initialize the DST start/end specs by DST law-date lookup table for the USA, then find
'the DST rule specs that apply, based on the specified date's year vs. the rule start-date years.
If IsEmpty(US_StartEndSpecs) Then '(Re)init if necessary...
US_StartEndSpecs = Array(Array(2007, Secnd, Mar, First, Nov), _
Array(1986, First, Mar, Last, Oct), _
Array(1966, Last, Apr, Last, Oct))
End If
For i = LBound(US_StartEndSpecs, 1) To UBound(US_StartEndSpecs, 1)
If DateYear >= US_StartEndSpecs(i)(LawYearIdx) Then Exit For
Next i
If i > UBound(US_StartEndSpecs, 1) Then
Stop 'DEBUG: SHOULD NEVER EXECUTE TO HERE DUE TO ChkDate PARAMETER VALUE CHECK, ABOVE.
Exit Function
End If
StartInstance = US_StartEndSpecs(i)(StartInstanceIdx) 'n-th Sunday of...
StartMonth = US_StartEndSpecs(i)(StartMonthIdx) 'some month
EndInstance = US_StartEndSpecs(i)(EndInstanceIdx) 'm-th Sunday of...
EndMonth = US_StartEndSpecs(i)(EndMonthIdx) 'some other month
End If
'Do the DST calculation based on the specifications defined above
CheckDST = ChkDate >= NthDayOfWeekDate(StartInstance, vbSunday, DateSerial(DateYear, StartMonth, 1)) And _
ChkDate < NthDayOfWeekDate(EndInstance, vbSunday, DateSerial(DateYear, EndMonth, 1))
End Function 'CheckDST
Public Function CheckDST_UK1972(ChkDate As Date) As Boolean
'
'Returns True if the UK "British Summer Time" applies to the specified date, based on the BST system as it's
'been defined since 1972; otherwise returns False. Note that this function does not take into account Harold
'Wilson's experimental "British Standard Time" which took place between October 27, 1968 and October 31, 1971.
'To correctly handle that date range, use the CheckDST function instead.
'
'PARAMETERS:
'
' ChkDate The date to be checked for DST status.
'
'AUTHOR: Peter Straton
'
'*************************************************************************************************************
Const Last As Integer = 5 'Last instance: use max possible in a month
Const Mar As Integer = 3, Oct As Integer = 10
Dim DateYear As Integer: DateYear = Year(ChkDate)
CheckDST_UK1972 = ChkDate >= NthDayOfWeekDate(Last, vbSunday, DateSerial(DateYear, Mar, 1)) And _
ChkDate < NthDayOfWeekDate(Last, vbSunday, DateSerial(DateYear, Oct, 1))
End Function 'CheckDST_UK1972
Public Function CheckDST_US2007(ChkDate As Date) As Boolean
'
'Returns True if the US Federal "Daylight Savings Time" applies to the specified date, based on the DST system
'established in 2007; otherwise returns False. Note that this function does not take into account locales
'such as Arizona, Hawaii or various US protectorates (Puerto Rico, Guam, etc.) so results for those locales
'will be unreliable. To correctly handle those locales, use the CheckDST function instead.
'
'PARAMETERS:
'
' ChkDate The date to be checked for DST status.
'
'AUTHOR: Peter Straton
'
'*************************************************************************************************************
Const First As Integer = 1 'First instance in a month
Const Secnd As Integer = 2 'Second instance in a month
Const Mar As Integer = 3, Nov As Integer = 11
Dim DateYear As Integer: DateYear = Year(ChkDate)
CheckDST_US2007 = ChkDate >= NthDayOfWeekDate(Secnd, vbSunday, DateSerial(DateYear, Mar, 1)) And _
ChkDate < NthDayOfWeekDate(First, vbSunday, DateSerial(DateYear, Nov, 1))
End Function 'CheckDST_US2007
Public Function IsDST(Optional Locale As String = "USA") As Boolean
'
'Returns True if Daylight Savings Time is *currently* in effect (in the optionally specified locale);
'otherwise returns False.
'
'*************************************************************************************************************
IsDST = CheckDST(Now(), Locale)
End Function
Function NthDayOfWeekDate(ByVal Instance As Integer, DayOfWeek As Integer, ByVal MonthDate As Date) As Date
'
'Returns the Date of the specified Nth instance of the specified day-of-week in the specified month.
'
'PARAMETERS:
'
' Instance The instance-number specified day-of-week in the month. To get the date of *last* instance in
' the month of the specified day-of-week, pass the value 5 as the argument to this parameter.
'
' DayOfWeek The day-number of the day-of-week for which the Nth instance is to be calculated. Can be any
' of: vbSunday, vbMonday, vbTuesday, vbWednesday, vbThursday, vbFriday, vbSaturday.
'
' MonthDate The date of the month in which the Nth day-of-week instance is to be calculated.
' (e.g. "3/2020" or "3/1/2020")
'
'AUTHOR: Peter Straton
'
'*************************************************************************************************************
Instance = IIf(Instance > 5, 5, Instance) 'Max: 5 possible instances
MonthDate = DateSerial(Year(MonthDate), Month(MonthDate), 1) 'Ensure that it's the first day of the month
NthDayOfWeekDate = MonthDate + Instance * 7 - Weekday(MonthDate + 7 - DayOfWeek)
If Month(NthDayOfWeekDate) <> Month(MonthDate) Then NthDayOfWeekDate = NthDayOfWeekDate - 7 '"Last" instance?
End Function
A few tweaks to Patrick Honorez's great solution.
A bit of error checking and some extra tests. :-)
Option Explicit
'mTimeZones by Patrick Honorez --- www.idevlop.com
'with the precious help of Julian Hess https://stackoverflow.com/a/45510712/78522
'You can reuse but please let all the original comments including this one.
'This modules uses late binding and therefore should not require an explicit reference to Outlook,
'however Outlook must be properly installed and configured on the machine using this module
'Module works with Excel and Access
'Murray Hopkins: a few tweaks for better useability
Private oOutl As Object 'keep Outlook reference active, to save time n recurring calls
Private Function GetOutlook() As Boolean
'get or start an Outlook instance and assign it to oOutl
'returns True if successful, False otherwise
If oOutl Is Nothing Then
'Debug.Print "~"
On Error Resume Next
Err.Clear
Set oOutl = GetObject(, "Outlook.Application")
If Err.Number Then
Err.Clear
Set oOutl = CreateObject("Outlook.Application")
End If
End If
GetOutlook = Not (oOutl Is Nothing)
On Error GoTo 0
End Function
Public Function ConvertTime(DT As Date, Optional TZfrom As String = "UTC", Optional TZto As String = "") As Date
'convert datetime with hour from Source time zone to Target time zone
'valid Source & Target time zones can be found in your registry under: HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Time Zones/
'this version using Outlook, properly handles Dailight Saving Times, including for past and future dates
'it includes a fix for the fact that ConvertTime seems to strip the seconds
'krammy85 2019-01-25 Edit: Outlook rounds minutes when it strips seconds, so modified code to strip seconds (without rounding) prior to running Outlook's ConvertTime.
Dim TZones As Object
Dim sourceTZ As Object
Dim destTZ As Object
Dim seconds As Single
Dim DT_SecondsStripped As Date
' If the conversion fails it will return the time unchanged
' You could change this if you want
Dim convertedTime As Date
convertedTime = DT
If GetOutlook Then
'fix for ConvertTime stripping the seconds
seconds = Second(DT) / 86400 'save the seconds as DateTime (86400 = 24*60*60)
DT_SecondsStripped = DT - seconds
Set TZones = oOutl.TimeZones
Set sourceTZ = TZones.item(TZfrom)
' Default to the timezone currently on this system if not passed in
If TZto = "" Then TZto = oOutl.TimeZones.CurrentTimeZone
Set destTZ = TZones.item(TZto)
If validTimeZoneName(TZfrom, sourceTZ) And validTimeZoneName(TZto, destTZ) Then
convertedTime = TZones.ConvertTime(DT_SecondsStripped, sourceTZ, destTZ) + seconds 'add the stripped seconds
End If
Else
Call MsgBox("Could not find MS-Outlook on this computer." & vbCrLf & "It mut be installed for this app to work", vbCritical, "ERROR")
End
End If
ConvertTime = convertedTime
End Function
' Make sure the time zone name returned an entry from the Registry
Private Function validTimeZoneName(tzName, TZ) As Boolean
Dim nameIsValid As Boolean
nameIsValid = True
If TZ Is Nothing Then
Call MsgBox("The timezone name of '" & tzName & "' is not valid." & vbCrLf & "Please correct it and try again.", vbCritical, "ERROR")
' This might be too harsh. ie ends the app.
' End
nameIsValid = False
End If
validTimeZoneName = nameIsValid
End Function
' Tests
Public Sub test_ConvertTime()
Dim t As Date, TZ As String
t = #8/23/2019 6:15:05 AM#
Debug.Print "System default", t, ConvertTime(t), Format(t - ConvertTime(t), "h:nn")
Call test_DoConvertTime("UTC", "AUS Eastern Standard Time")
Call test_DoConvertTime("UTC", "AUS Central Standard Time")
Call test_DoConvertTime("UTC", "E. Australia Standard Time")
Call test_DoConvertTime("UTC", "Aus Central W. Standard Time")
Call test_DoConvertTime("UTC", "W. Australia Standard Time")
Call test_DoConvertTime("W. Australia Standard Time", "AUS Eastern Standard Time")
' Throw error
Call test_DoConvertTime("UTC", "Mars Polar Time")
End
End Sub
Public Sub test_DoConvertTime(ByVal fromTZ As String, ByVal toTZ As String)
Dim t As Date, TZ As String, resDate As Date, msg
t = #8/23/2019 6:15:05 AM#
resDate = ConvertTime(t, fromTZ, toTZ)
msg = fromTZ & " to " & toTZ
Debug.Print msg, t, resDate, Format(t - resDate, "h:nn")
End Sub