• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA-code voor waarschuwing bij bereiken expiratie datum

Status
Niet open voor verdere reacties.
R

Revolutionary

Gebruiker
Lid geworden
1 apr 2009
Berichten
183
Beste helpers,

Ik heb een excelsheet met in Kolom F de expiratiedatum van de contracten uit kolom C.
Nu zou ik graag bij het openen van het bestand een waarschuwing willen krijgen als de expiratiedatum binnen 7 dagen bereikt wordt. Op internet vond ik onderstaande VBA code die ik wat heb aangepast zodat hij zou moeten werken op mijn bestand.

Code: 
Private Sub Workbook_Open()

    Dim LRow As Integer
    Dim LResponse As Integer
    Dim LName As String
    Dim LDiff As Integer
    Dim LDays As Integer
    
    LRow = 15
    
    'Warning - Number of days to check for expiration
    LDays = 7
    
    'Check the first 1000 rows in column C
    While LRow < 1000
        
        'Only check for expired certificate if value in column C is not blank
        If Len(Sheets("Update Too").Range("F" & LRow).Value) > 0 Then
        
            [COLOR="red"]LDiff = DateDiff("d", Date, Sheets("Update Too").Range("F" & LRow).Value)[/COLOR]            
        If (LDiff > 0) And (LDiff <= LDays) Then
                'Get subcontractor name
                LName = Sheets("Update Too").Range("C" & LRow).Value
                LResponse = MsgBox("The position in " & LName & " will expire in " & LDiff & " days.", vbCritical, "Warning")
            End If
        End If
        
        LRow = LRow + 1
    Wend
    
End Sub

De code werkt deels, bij het openen van het bestand wordt van de eerste 2 markten een melding gemaakt dat de expiratiedatum nadert, daarna krijg ik echter een foutmelding. (zie bijlage: Bekijk bijlage voorbeeld - exp datum.xlsx) Dat komt doordat er in kolom F niet alleen expiratie data staat maar ook tekst. Weet iemand hoe ik de VBA-code kan aanpassen zodat de macro werkt zonder dat ik de tekst in kolom F moet weghalen? Of heeft iemand een vergelijkbare vba-code voor het geven van waarschuwingen bij expiratie datum die ik kan aanpassen?

Alvast bedankt!

Tim
 
Laatst bewerkt:
Revolutionary

Als je "Market Currency Month Expiration Date" bij het 2e en 3e blok weg haald, loopt de macro wel door.
Dit heb ik getest door met F8 door de code te lopen en de cursor onderaan op Lrow te houden kun je zien op welke regel hij stopt cq fout geef.
 
Laatst bewerkt:
Beste ExcelAmateur,

Ja daar was ik al achter gekomen, daarom is mijn vraag ook hoe ik de vba-code kan aanpassen zonder dat ik de tekst in Kolom F hoef te verwijderen. Het is namelijk niet wenselijk om de tekst daar weg te halen, ook al lijkt het in het voorbeeld bestandje als overbodig.

Mvg,
Tim
 
Revolutionary,

Ik ben maar een amateur, zeker met VBA.
Er zijn hier wel een paar knappe koppen met VBA misschien weten zij een oplossing.
Suc6
 
Revolutionary,

Ik heb dit stukje code er tussen gezet en nu liep hij wel door, misschien de oplossing?
Code: 
While LRow < 1000
        If LRow = 17 Then LRow = 20
 
Bedankt voor je hulp ExcelAmateur:thumb:

Hier kan ik misschien wel wat mee, want als ik dat stukje code plaats op alle regels waar tekst voorkomt zou mijn probleem misschien opgelost kunnen zijn.

Ik ga het even testen, het oorspronkelijk bestand telt ongeveer 300 regels, met 40 keer regels met tekst er tussen, dus ik het zal even duren.

Ik hou je op de hoogte!
 
Het is misschien niet de mooiste oplossing maar het werkt.
Er zal best wel iemand wezen die een betere oplossing heeft.
 
De oplossing hoeft geen schoonheidsprijs te winnen, zo lang die maar werkt:)

En het lijkt te werken, ik heb het nu voor 4 van de 20 regels gedaan and so far so good.
 
Lichtjes aangepast:

Code: 
Private Sub Workbook_Open()
    Dim cel As Range, LName As String, LResponse As Integer, LDiff As Integer, LDays As Integer
    LDays = 7
    For Each cel In Sheets("Update Too").Range("f1:f" & Sheets("Update Too").Cells(Rows.Count, "F").End(xlUp).Row)
        If cel.Value <> "" And IsDate(cel.Value) Then
            LDiff = DateDiff("d", Date, cel.Value)
            If (LDiff > 0) And (LDiff <= LDays) Then
                LName = cel.Offset(0, -3).Value
                LResponse = MsgBox("The position in " & LName & " will expire in " & LDiff & " days.", vbCritical, "Warning")
            End If
        End If
    Next
End Sub
 
@ ExcelAmateur, je stukje code werkt:) dus misschien ben je toch niet zo'n amateur in VBA;) je weet er in ieder geval meer vanaf dan ik!

@ E v R, jouw code werkt ook, dus ik heb een luxe probleem. Ik kies dan toch voor de code van E v R, want mochten er in het bestand ooit markten bijkomen of regels verplaatst worden dan hoef ik de vba-code niet steeds aan te passen.

Bedankt allebei:thumb:

Ik zet deze topic op opgelost.
 
Lijkt mij nogal lastig, als er veel contracten zijn die binnen die 7 dagen vallen, steeds die messagebox te zien verschijnen. Waarom niet de contracten markeren met een kleur via voorwaardelijke opmaak? Is nog veel eenvoudiger ook.
 
Daar heb ik inderdaad ook over nagedacht Zapatr, echter het aantal contracten dat binnen 7 dagen afloopt zal in de praktijk waarschijnlijk gering zijn. Het gaat om termijncontracten op commodities, bij een waarschuwing wordt een contract doorgerold, maw wordt het huidige contract gesloten en tegelijkertijd een nieuw contract aangekocht met een langere looptijd. Vervolgens wordt deze looptijd weer aangepast in het excelbestand. De sheet heeft weleenswaar 300 rijen, maar in de praktijk is maar zo'n 10% van de rijen in gebruik.

Toch bedankt voor het meedenken:thumb:

Mvg,
Tim
 
Mocht je je nog bedenken of het willen proberen,
dan kun je deze voorw. opmaak gebruiken voor rij 15
Code: 
=en($F15-vandaag()<7;$F15-vandaag()>0)
Kopieer die voorw. opmaak naar beneden.
 
Thanks, als ik uiteindelijk gek word van al die messageboxen dan zal ik jouw formule eens uitproberen:thumb:

Fijne avond!

Tim
 
Je kunt natuurlijk ook alle meldingen in één message box zetten
 
1 msgbox, kijkt 7 dagen achteruit en 7 dagen vooruit, dat kan je zo aanpassen
Code: 
Sub VerlopenContracten()
  Dim UR As Range, cConst As Range, cForm As Range, KolDatums As Range, c As Range, Tekst As String
  With Sheets("update too")                                'in dit werkblad
    Set UR = .UsedRange                                    'beperken tot usedrange
    On Error Resume Next
    Set cConst = UR.Offset(, Columns("F").Column - UR.Column).SpecialCells(xlConstants, xlNumbers)  'alle vaste getallen in kolom F
    Set cForm = UR.Offset(, Columns("F").Column - UR.Column).SpecialCells(xlFormulas, xlNumbers)  'alle berekende getallen (via formules) in kolom F
    Set KolDatums = Intersect(.Columns("F"), Union(IIf(cConst Is Nothing, .Range("A1"), cConst), IIf(cForm Is Nothing, .Range("A1"), cForm)))  'alle getallen in kolom F
    If KolDatums Is Nothing Then
      MsgBox "er zijn geen datums in kolom F"
    Else
      For Each c In KolDatums.Cells                        '1 voor 1 alle getallen aflopen
        If IsDate(c) Then                                  'is het een datum
          If Date - 7 <= c.Value And c.Value <= Date + 7 Then  'ongeveer vervaldatum
            Tekst = Tekst & c.Offset(, -3).Value & " : contract verloopt op " & Format(c.Value, "ddd dd-mm-yy") & vbLf
            c.EntireRow.Interior.ColorIndex = 3
          End If
        End If
      Next
    End If
  End With
  If Tekst <> "" Then MsgBox Tekst
End Sub
 
Thanks cow18:thumb:

Ik heb je code getest en het ziet er goed uit, ik heb alleen de regel verwijderd die de rijen rood maakt. Is het mogelijk om ipv een hele rij rood te maken alleen de cel waar de datum van expiratie in staat rood te maken?

Alle waarschuwingen in 1 messagebox werkt denk ik inderdaad beter, dus ik denk dat ik deze code in mijn excel bestand zet.

Ik weet niet of het veel werk is, maar is het mogelijk om een deel van de eerste code van E v R te gebruiken in de tweede code van Cow18? Het zou wel mooi zijn als in de messagebox staat hoeveel dagen er nog over zijn tot expiratie (zoals het geval bij de eerste vba-code) in plaats van de datum van expiratie zelf te vermelden (zoals het geval bij de tweede vba-code). Als je denkt dat er teveel tijd in gaat zitten, dan hoeft het niet hoor, maar als ik het een kwestie is van knippen en plakken zou het wel een mooie toevoeging zijn:)

Anyway, iedereen super bedankt!

Tim
 
Code: 
Sub VerlopenContracten()
  Dim UR As Range, cConst As Range, cForm As Range, KolDatums As Range, c As Range, Tekst As String, verschil As Integer, Lresponse As Variant
  With Sheets("update too")                                'in dit werkblad
    Set UR = .UsedRange                                    'beperken tot usedrange
    On Error Resume Next
    Set cConst = UR.Offset(, Columns("F").Column - UR.Column).SpecialCells(xlConstants, xlNumbers)  'alle vaste getallen in kolom F
    Set cForm = UR.Offset(, Columns("F").Column - UR.Column).SpecialCells(xlFormulas, xlNumbers)  'alle berekende getallen (via formules) in kolom F
    Set KolDatums = Intersect(.Columns("F"), Union(IIf(cConst Is Nothing, .Range("A1"), cConst), IIf(cForm Is Nothing, .Range("A1"), cForm)))  'alle getallen in kolom F
    If KolDatums Is Nothing Then
      MsgBox "er zijn geen datums in kolom F"
    Else
      For Each c In KolDatums.Cells                        '1 voor 1 alle getallen aflopen
        If IsDate(c) Then                                  'is het een datum
          verschil = c.Value - Date
          Select Case verschil
            Case 0 To 7                                    'binnen de 7 dagen aflopen
              Tekst = Tekst & "The position in " & c.Address & ", " & c.Offset(, -3).Value & " on  " & c.Value & " will expire in " & verschil & " days." & vbLf
              c.Interior.ColorIndex = 3
          End Select
        End If
      Next
    End If
  End With
  If Tekst <> "" Then Lresponse = MsgBox(Tekst, vbCritical, "Warning")
End Sub
 
Super bedankt cow18!:thumb:

Ik wou dat ik zo handig was met VBA!

@ Lucien: ik denk niet dat dat mogelijk is via Excel, al zou het wel een mooie optie zijn, maar de experts op dit forum kunnen je daar waarschijnlijk wel meer over vertellen.

Ik zet deze topic op opgelost!

Nogmaals bedankt iedereen die mij bij dit vraagstuk geholpen heeft!:d
 
@ lucienseinen Graag een eigen vraag maken a.u.b. Het is niet netjes om in een ander zijn of haar vraag jouw probleem aan de orde te stellen. Bovendien is het verwarrend voor de helpers en de oorspronkelijke vragensteller. Tevens worden je hier diversen oplossingen aangedragen
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan