DZone Snippets: vba code

Add lines of code to module in design view using VBEIDE

AccessExpert (Juan Soto) — Mon, 28 Apr 2008 01:38:04 GMT

Sometimes you'll need to add code programmatically to your Form or Report Module, for example, when you need to add the same code to all controls of a certain type on a form. When the form has a handful of controls it's no big deal, but when there may be dozens or hundreds of controls it can be daunting. The code below will cycle through all of the controls on your form, determine if the control type has to be updated, check to see if the control already has an event defined, and if not, create the event and append the code. Otherwise it'll print the name of the procedure it didn't modify. Prior to running the code please add the reference "Microsoft Visual Basic for Applications Extensibility 5.3" to your project.

Note: The form specified in strForm below must be in design view prior to running the code in order for this to work.

You can call the procedure using:
AddCodeToControls("Form_myForm", "Msgbox " & chr(34) & "Hello World" & chr(34) , "BeforeUpdate"



' This code was originally written by Juan Soto at AccessExperts.net.

' It is not to be altered or distributed,

' except as part of an application.

' You are free to use it in any application,

' provided the copyright notice is left unchanged.

'

' Code Courtesy of

' Juan Soto at AccessExperts.net



Public Function AddCodeToControls(strFormName As String, strCode As String, strProcedure As String)

    On Error Resume Next

    Dim VBAEditor As VBIDE.VBE

    Dim VBProj As VBIDE.VBProject

    Dim VBComp As VBIDE.VBComponent

    Dim CodeMod As VBIDE.CodeModule

    Dim obj As Object

    Dim frm As Form

    Dim ctl As Access.Control

    Dim lngHeaderLine As Long

    

    Set VBAEditor = Application.VBE

    Set VBProj = VBAEditor.ActiveVBProject

    Set VBComp = VBProj.VBComponents(strFormName)

    Set CodeMod = VBComp.CodeModule

    Set frm = Forms(strform)

    For Each ctl In frm.Controls

        If ctl.ControlType = acCheckBox Or ctl.ControlType = acComboBox Or ctl.ControlType = acListBox _

            Or ctl.ControlType = acTextBox Then

            'Search if object already has an after update event

            lngHeaderLine = CodeMod.ProcStartLine(ctl.Name & "_" & strProcedure, vbext_pk_Proc)

            If Err > 0 Then

                'Procedure does not exist, create it

                lngHeaderLine = CodeMod.CreateEventProc(strProcedure, ctl.Name)

                CodeMod.InsertLines lngHeaderLine + 1, strCode

            Else

                'Procedure does exist, print name for manual editing later

                Debug.Print ctl.Name & "_" & strProcedure & " Not Modified"

            End If

        End If

    Next ctl



End Function

Calculate Last Day of Last Month

jokeyxero (xero) — Fri, 01 Feb 2008 22:51:12 GMT

VB/VBA/VB.NET one-liner to calculate the end of last month. Useful for SSRS/RDL Expressions and Excel/Office Formulas. Note that it does not use string parsing, which can cause localization problems.



DateAdd("d", -1.0 * DatePart("d", Today), Today)

Calculate First Day of Current Month

jokeyxero (xero) — Fri, 01 Feb 2008 22:48:45 GMT

VB/VBA/VB.NET one-liner to calculate the start of the current month. Useful for SSRS/RDL Expressions and Excel/Office Formulas. Note that it does not use string parsing, which can cause localization problems.



DateAdd("D", -1.0 * DatePart("D", Today) + 1, Today)

Calculate First Day of Last Month

jokeyxero (xero) — Fri, 01 Feb 2008 22:47:11 GMT

VB/VBA/VB.NET one-liner to calculate the start of the previous month. Useful for SSRS/RDL Expressions and Excel/Office Formulas. Note that it does not use string parsing, which can cause localization problems.



DateAdd("D", -1.0 * DatePart("D", Today) + 1, DateAdd("m", -1, Today))

Excel : Make a query on a Oracle database and return the result (useful for sheet formulas)

bouffon69 (Sylvain Le Courtois) — Mon, 10 Sep 2007 15:26:22 GMT

// This should be pasted in a module of the workbook



Function ORAQUERY(strHost As String, strDatabase As String, strSQL As String, strUser As String, strPassword As String)

  Dim strConOracle, oConOracle, oRsOracle

  Dim StrResult As String

  

  StrResult = ""

  

  strConOracle = "Driver={Microsoft ODBC for Oracle}; " & _

         "CONNECTSTRING=(DESCRIPTION=" & _

         "(ADDRESS=(PROTOCOL=TCP)" & _

         "(HOST=" & strHost & ")(PORT=1521))" & _

         "(CONNECT_DATA=(SERVICE_NAME=" & strDatabase & "))); uid=" & strUser & " ;pwd=" & strPassword & ";"

  Set oConOracle = CreateObject("ADODB.Connection")

  Set oRsOracle = CreateObject("ADODB.Recordset")

  oConOracle.Open strConOracle

  Set oRsOracle = oConOracle.Execute(strSQL)

  Do While Not oRsOracle.EOF

      If StrResult <> "" Then

        StrResult = StrResult & Chr(10) & oRsOracle.Fields(0).Value

      Else

        StrResult = oRsOracle.Fields(0).Value

      End If

    oRsOracle.MoveNext

  Loop

  oConOracle.Close

  Set oRsOracle = Nothing

  Set oConOracle = Nothing

  ORAQUERY = StrResult

End Function

VBA procedure to pen an Excel workbook and refresh all datas in the QueryTables and PivotTable objects

bouffon69 (Sylvain Le Courtois) — Fri, 07 Sep 2007 07:44:29 GMT

// description of your code here
// Can also use the Workbook Open event ( Private Sub Workbook_Open() )



Sub Auto_Open()

Application.DisplayAlerts = False

    ChDir "T:\EXPLOIT\TSMENV\EXCEL\politiques"

    Workbooks.Open Filename:="t:\EXPLOIT\TSMENV\EXCEL\politiques\politiques.xls", _

        UpdateLinks:=3

    For i = 1 To ActiveWorkbook.PivotCaches.Count

        ActiveWorkbook.PivotCaches(i).RefreshOnFileOpen = False

    Next

    For i = 1 To ActiveWorkbook.Sheets.Count

        For j = 1 To ActiveWorkbook.Sheets(i).QueryTables.Count

            ActiveWorkbook.Sheets(i).QueryTables(j).RefreshOnFileOpen = False

        Next

    Next

    ActiveWorkbook.RefreshAll

    ActiveWorkbook.RefreshAll

    ActiveWorkbook.RefreshAll

    ActiveWorkbook.Save

    ActiveWindow.Close

    Application.Quit

End Sub

feiertage berechnen / calculate holidays

berot3 (berot3) — Fri, 10 Aug 2007 14:31:42 GMT

// noch nicht fertig



Option Compare Database



    'zunächst auf Modulebene im Klassenmodul definiert,

        'und zwar als dynamisches Array des Typs FTag

Dim arrFTage() As FTag

Dim typFTag As FTag



    'Da öffentliche Datentypen in Klassenmodulen nicht zulässig sind,

        'müssen Sie hier zwingend das Schlüsselwort Private verwenden

Private Type FTag

    Tag As Byte

    Monat As Byte

    Name As String

    Land As String

End Type



'Klassenmodul ein und setzen dessen Name Eigenschaft auf clsFeiertage

    'Innerhalb der Klasse erstellen Sie eine öffentliche Funktion

    'Ostersonntag(), der Sie als Parameter die Jahreszahl übergeben

    'Damit ist schon die erste Variable der Formel bekannt.

Public Function Ostersonntag(lngJahr As Long) As Variant



Dim strFehler As String

Dim lngTag As Long

Dim bytMonat As Byte

Dim bytA As Byte

Dim bytB As Byte

Dim bytM As Byte

Dim bytN As Byte

Dim lngE As Long

Dim lngD As Long



    'Berechnen von A, B und C

bytA = lngJahr Mod 19

bytB = lngJahr Mod 4

bytC = lngJahr Mod 7

    'Ermitteln von M und N

bytM = 0

bytN = 0

    'gemäß der "Tabelle" in getMundN berechnet und zurückgibt

strFehler = getMundN(bytM, bytN, lngJahr)



If strFehler = "" Then

        'Berechnung fortsetzen

        'Berechnen von D

    lngD = ((19 * bytA) + bytM) Mod 30

    lngE = ((2 * bytB) + (4 * bytC) + (6 * lngD) + bytN) Mod 7

        'Tag berechnen

    lngTag = 22 + lngD + lngE

        'Ausnahmen prüfen

        'Ist Ostersonntag größer als 31, fällt Ostern in den April.

        'Der Tag wird dann wie folgt berechnet: Ostersonntag =D+E-9.

    If lngTag > 31 Then

        bytMonat = 4

        lngTag = lngD + lngE - 9

        

            'weitere Ausnahmen prüfen

        If lngTag = 26 Then

                'Ist Ostersonntag der 26. April fällt Ostern

                'auf den 19. April

            lngTag = 19

        ElseIf lngTag = 25 Then

                'Ist Ostersonntag der 25. April und gleichzeitig

                'A > 10 und D = 28, dann ist Ostersonntag der 18. April

            If (bytA > 10) And (bytB = 28) Then

                lngTag = 18

            End If

        End If

        

    Else

    

        bytMonat = 3

    End If

End If



    'Gültigkeitsprüfung durchführen

    'Prüfen, ob das Datum gültig ist.

If (bytMonat > 0) And (lngTag > 0) Then



    Ostersonntag = DateSerial(lngJahr, bytMonat, lngTag)

    

        'prüfen, ob das berechnete Datum ein Sonntag ist.

    If Weekday(Ostersonntag, vbSunday) > 1 Then

    

        strFehler = "Berechnungsfehler: Ostersonntag " & _

         "liegt nicht an einem Sonntag!"

        

        Ostersonntag = strFehler & vbCrLf & "Berechnungergebnis: " _

         & Format(Ostersonntag, "dd.MM.yyyy", vbSunday)

    End If

Else



    Ostersonntag = strFehler

End If



End Function



Private Function getMundN(ByRef bytM As Byte, ByRef bytN As Byte, _

 lngJahr As Long) As String

 

getMundN = ""



Select Case lngJahr

    Case 1582 To 1699:

        bytM = 22

        bytN = 2

    Case 1700 To 1799:

        bytM = 23

        bytN = 3

    Case 1800 To 1899:

        bytM = 23

        bytN = 4

    Case 1900 To 2099:

        bytM = 24

        bytN = 5

    Case 2100 To 2199:

        bytM = 24

        bytN = 6

    Case 2200 To 2299:

        bytM = 25

        bytN = 0

    Case 2300 To 2399:

        bytM = 26

        bytN = 1

    Case 2400 To 2499:

        bytM = 25

        bytN = 1

Case Else

    getMundN = "Die Jahreszahl muss zwischen 1581 und 2500 liegen!"

End Select

End Function



Public Function Ostermontag(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Ostermontag = DateAdd("d", 1, varTemp)

    Else

        Ostermontag = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Karfreitag(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Karfreitag = DateAdd("d", -2, varTemp)

    Else

        Karfreitag = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Pfingstsonntag(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Pfingstsonntag = DateAdd("d", 49, varTemp)

    Else

        Pfingstsonntag = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Pfingstmontag(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Pfingstmontag = DateAdd("d", 50, varTemp)

    Else

        fingstmontag = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Rosenmontag(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Rosenmontag = DateAdd("d", -48, varTemp)

    Else

        Rosenmontag = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Fastnacht(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Fastnacht = DateAdd("d", -47, varTemp)

    Else

        Fastnacht = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Aschermittwoch(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Aschermittwoch = DateAdd("d", -46, varTemp)

    Else

        Aschermittwoch = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Himmelfahrt(lngJahr As Long) As Variant

    Dim varTemp As Variant

    varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Himmelfahrt = DateAdd("d", 39, varTemp)

    Else

        Himmelfahrt = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

Public Function Fronleichnam(lngJahr As Long) As Variant

        Dim varTemp As Variant

        varTemp = Ostersonntag(lngJahr)

    If IsDate(varTemp) Then

        Fronleichnam = DateAdd("d", 60, varTemp)

    Else

        Fronleichnam = varTemp 'Fehlermeldung zurückgeben

    End If

End Function

'############################################################

    'Zum Lesen der Datei reicht eine private Prozedur,

        'der Sie den Dateinamen einschließlich des Pfads

        'der Textdatei übergeben

Private Sub FeiertageLesen(strDateiname As String)



Dim lngDatei As Long

Dim strFehler As String

Dim strZeile As String

Dim varZeile As Variant

Dim lngZeile As Long



On Error GoTo FEHLER



lngDatei = FreeFile()



    ' Datei öffnen.

Open strDateiname For Input As #lngDatei



    'Auslesen der Einträge und einfügen in das Array

ReDim arrFTage(1)

lngZeile = -1



    'lesen sie in einer Schleife zeilenweise aus

    'Schleife bis Dateiende.

Do While Not EOF(lngDatei)

    Input #lngDatei, strZeile

    

    If Trim(strZeile) > "" Then

        On Error Resume Next

        

            'Jede Zeile splitten Sie mit Hilfe der Split-Funktion in ein Array

        varZeile = Split(strZeile, ";")

        

        typFTag.Tag = varZeile(0)

        typFTag.Monat = varZeile(1)

        typFTag.Name = varZeile(2)

        typFTag.Land = varZeile(3)

        

        On Error GoTo FEHLER

    

    End If

    

        'Array vergrößern

    lngZeile = lngZeile + 1

    arrFTage(lngZeile) = typFTag

    ReDim Preserve arrFTage(UBound(arrFTage) + 1)

    Debug.Print strZeile

Loop



Close #lngDatei



    'Texdatei öffnen

Exit Sub



'---------------------------------------------------------

FEHLER:



If Err.Number = 52 Then

    strFehler = "Die Datei " & strDateiname & _

    " ist nicht vorhanden oder kann nicht geöffnet werden!"

End If



    'Debug.Print Err.Number & ": " & Err.Description

If strFehler > "" Then

    On Error Resume Next

    MsgBox strFehler

    Close #lngDatei

    Exit Sub

End If



End Sub



Public Function FixFeiertag(datDatum As Date, _

    strDateiname As String, Optional strLand) As String

    

    'Prüft ob es sich bei dem Datum um einen fixen Feiertag handelt

    'Falls ja, wird der Name des Feiertags zurückgegeben

    

Dim bytFehler As Byte

Dim bytTag As Byte

Dim bytMonat As Byte

Dim lngZage



bytFehler = 0

FixFeiertag = ""



On Error GoTo FEHLER



    'Array durchsuchen

        'weil bei einem noch nicht initialisierten Array

        'das Abrufen der oberen Indexgrenze mit ubound einen

        'Laufzeitfehler verursacht.

If UBound(arrFTage) >= 0 Then

        'zunächst aus dem Parameter datDatum der Tag

            'und der Monat ermittelt und in zwei Variablen gespeichert

    bytTag = Day(datDatum)

    bytMonat = Month(datDatum)

    

        'Danach durchläuft eine Schleife das Array.

            'Für den Fall, dass der optionale Parameter strLand

            'nicht übergeben wurde, wird nur geprüft,

            'ob Monat und Tag des aktuellen Array-Eintrags mit den Werten

            'in den beiden Variablen übereinstimmen

        'Wird zusätzlich das Land angegeben, wird auch dieses in die Prüfung einbezogen.

    For lngZeile = LBound(arrFTage) To UBound(arrFTage)

        typFTag = arrFTage(lngZeile)

        

        If IsMissing(strLand) Then

        

            If (bytTag = typFTag.Tag) _

            And (bytMonat = typFTag.Monat) Then

                    'der Name des Feiertags als Rückgabewert festgelegt

                FixFeiertag = typFTag.Name

                Exit For

            End If

            

        Else

    

            If (bytTag = typFTag.Tag) _

            And (bytMonat = typFTag.Monat) _

            And (strLand = typFTag.Land) Then

                    'der Name des Feiertags als Rückgabewert festgelegt

                FixFeiertag = typFTag.Name

                Exit For

            End If

            

        End If

        

    Next lngZeile ' <- befindet sich im For oder nicht?

End If



Exit Function



'---------------------------------------------------------

FEHLER:

    'Ist dies die Zahl 9, war das Array noch nicht initialisiert

        'und die Prozedur FeiertageLesen wird aufgerufen

bytFehler = bytFehler + 1

If Err.Number = 9 Then

    If bytFehler = 1 Then

        FeiertageLesen strDateiname

        Resume

    Else

        Exit Function

    End If

End If



End Function











'Methoden zum Erfassen von Feiertagen

'Wenn Sie dem Benutzer der Anwendung, der die Klasse verwendet,

'die Möglichkeit geben möchten, feste Feiertage über ein Formular

'oder eine UserForm zu erfassen, sollten Sie dazu schon in der

'Klasse eine Methode vorsehen, die an die Textdatei eine Zeile

'mit neuen Werten anhängt. Diese Methode soll hier

'FeierTagSchreiben lauten (Listing 4). Ihr übergeben Sie die zu

'schreibenden Werte für die einzelne Spalte sowie den Dateinamen

'und den Pfad der Textdatei. Die Methode schreibt diese Daten

'dann in die Textdatei.

Public Sub FeierTagSchreiben(strDateiname As String, _

 bytTag As Byte, bytMonat As Byte, strName As String, strLand As String)



Dim lngDatei As Long

Dim strFehler As String

Dim strZeile As String

Dim varZeile As Variant

Dim lngZeile As Long

Dim bytFehler As Byte

bytFehler = 0



On Error GoTo FEHLER



lngDatei = FreeFile()

    'Datei öffnen.

Open strDateiname For Append As #lngDatei

    'Textdatei öffnen und Daten schreiben

Print #lngDatei, bytTag & ";" & bytMonat & ";" & strName & ";" & strLand

Close #lngDatei



Exit Sub



'---------------------------------------------------------

FEHLER:

bytFehler = bytFehler + 1

If Err.Number = 52 Then

    strFehler = "Die Datei " & strDateiname & _

     " ist nicht vorhanden oder kann nicht geöffnet werden!"

ElseIf Err.Number = 55 Then

    If bytFehler < 5 Then

        Resume

    Else

        strFehler = "In die Datei konnte nicht geschrieben werden!"

    End If

End If

        

If strFehler > "" Then

    On Error Resume Next

    MsgBox strFehler

    Close #lngDatei

    

    Exit Sub

End If



End Sub

Detect a field edit in Excel and refresh a Query

davetrane (David Davis) — Fri, 02 Mar 2007 04:29:25 GMT



Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wks As Worksheet

    Set wks = ActiveSheet



    If Target.Row = 1 And Target.Column = 1 Then

      wks.QueryTables(1).Refresh

    End If



    Set wks = Nothing

End Sub

VBA DDE WORD EXCEL

millerjohneric (John Miller) — Fri, 08 Dec 2006 22:50:58 GMT

// This is just sample code of some dde commands



Sub RUNEXCELMACRO()

'RUN MACRO

aChan = DDEInitiate(App:="Excel", Topic:="System")

DDEExecute Channel:=aChan, Command:="[Run(" & Chr(34) & _

    "Personal.xls!Macro1" & Chr(34) & ")]"

DDETerminate Channel:=aChan

'POKE

Chan = DDEInitiate(App:="Excel", Topic:="System")

DDEExecute Channel:=Chan, Command:="[OPEN(" & Chr(34) _

    & "C:\Sales.xls" & Chr(34) & ")]"

DDETerminate Channel:=Chan

Chan = DDEInitiate(App:="Excel", Topic:="Sales.xls")

DDEPoke Channel:=Chan, Item:="R1C1", Data:="1996 Sales"

DDETerminate Channel:=Chan

'This example opens the Microsoft Excel workbook Book1.xls and retrieves the contents of cell R1C1.

Chan = DDEInitiate(App:="Excel", Topic:="System")

DDEExecute Channel:=Chan, Command:="[OPEN(" & Chr(34) _

    & "C:\My Documents\Book1.xls" & Chr(34) & ")]"

DDETerminate Channel:=Chan

Chan = DDEInitiate(App:="Excel", Topic:="C:\DATA\SBS.xls")

msg = DDERequest(Channel:=Chan, Item:="R2C1")

msg = msg & " " & DDERequest(Channel:=Chan, Item:="R2C2")

MsgBox msg

DDETerminateAll

'This example opens a channel to the System topic in Microsoft Excel and then uses the Topics item to return a list of available topics. The example inserts the topic list, which includes all open workbooks, after the selection.

aChan = DDEInitiate(App:="Excel", Topic:="System")

TOPICLIST = DDERequest(Channel:=aChan, Item:="Topics")

Selection.InsertAfter TOPICLIST

DDETerminate Channel:=aChan



End Sub

work days between two dates without cycling through dates

Will_Rickards (Will Rickards) — Thu, 13 Oct 2005 23:24:13 GMT

I was thinking about how to optimize figuring out the work days between two dates and came up with this function. It doesn't take into account holidays. You would have to take out the workdays for holidays from the number if you want to take into account holidays, but that should be easy enough.

4GL Version

 

# workdays

# returns the number of working days between two dates

FUNCTION workdays( dt_begin, dt_end )



DEFINE

   dt_begin             DATE,

   dt_end               DATE,

   dt_first_sunday      DATE,

   dt_last_saturday     DATE,

   int_workdays         INTEGER



   # get first sunday

   LET dt_first_sunday = dt_begin + ((7 - WEEKDAY(dt_begin)) MOD 7)



   # get last saturday

   LET dt_last_saturday = dt_end + ((-1 * (WEEKDAY(dt_end) + 1)) MOD 7)



   # get work weeks between first sunday and last saturday

   LET int_workdays = (((dt_last_saturday - dt_first_sunday) + 1) / 7) * 5

   

   # if first sunday is not begin date

   IF dt_first_sunday <> dt_begin THEN



      # assume first sunday is after begin date

      # add workdays from begin date to first sunday

      LET int_workdays = int_workdays + (6 - WEEKDAY(dt_begin))



   END IF



   # if last saturday is not end date

   IF dt_last_saturday <> dt_end THEN



      # assume last saturday is before end date

      # add workdays from last saturday to end date

      LET int_workdays = int_workdays + WEEKDAY(dt_end)  

  

   END IF



   # return working days

   RETURN int_workdays



END FUNCTION

VBA Version



' WorkDays

' returns the number of working days between two dates

Public Function WorkDays(ByVal dtBegin As Date, ByVal dtEnd As Date) As Long



   Dim dtFirstSunday As Date

   Dim dtLastSaturday As Date

   Dim lngWorkDays As Long



   ' get first sunday in range

   dtFirstSunday = dtBegin + ((8 - Weekday(dtBegin)) Mod 7)



   ' get last saturday in range

   dtLastSaturday = dtEnd - (Weekday(dtEnd) Mod 7)



   ' get work days between first sunday and last saturday

   lngWorkDays = (((dtLastSaturday - dtFirstSunday) + 1) / 7) * 5



   ' if first sunday is not begin date

   If dtFirstSunday <> dtBegin Then



      ' assume first sunday is after begin date

      ' add workdays from begin date to first sunday

      lngWorkDays = lngWorkDays + (7 - Weekday(dtBegin))



   End If



   ' if last saturday is not end date

   If dtLastSaturday <> dtEnd Then



      ' assume last saturday is before end date

      ' add workdays from last saturday to end date

      lngWorkDays = lngWorkDays + (Weekday(dtEnd) - 1)



   End If



   ' return working days

   WorkDays = lngWorkDays



End Function