Melding met MsgBox als datum bijna bereikt is.

danny147 · 11 jan 2011

Beste,

Ik heb een MsgBox aangemaakt die mij zegt binnen een bepaalde tijd wanneer we onze hijskabels moeten vervangen op het werk.

Deze is aangemaakt voor 1 cel nl. B4.

Graag zou ik willen dat hij de kolom B nakijkt op datum en welke LK (LoopKraan) in kolom A moet vervangen worden.

Groetjes Danny. :thumb:

zapatr · 11 jan 2011

Een oplossing met voorwaardelijke opmaak (zie bijlage).
Rood: binnen 1 week vervangen.
Paars: binnen 14 dagen vervangen.
Geel: binnen 1 maand vervangen.

Warme bakkertje · 11 jan 2011

Alvast een begin

Code:

Private Sub Workbook_Open()
For Each cl In [B4:B11]
    If cl <= [A1] + 7 Then
        sq = sq & cl.Offset(, -1) & "|"
        x = x + 1
    ElseIf cl <= [A1] + 14 And cl > [A1] + 7 Then
        sq2 = sq2 & cl.Offset(, -1) & "|"
        y = y + 1
    ElseIf cl <= [A1] + 30 And cl > [A1] + 14 Then
        sq3 = sq3 & cl.Offset(, -1) & "|"
        z = z + 1
    End If
Next
[E1].Resize(, 3) = Split("Deze week|Binnen 14 dagen|Deze maand", "|")
[E2].Resize(x) = WorksheetFunction.Transpose(Split(sq, "|"))
[F2].Resize(y) = WorksheetFunction.Transpose(Split(sq2, "|"))
[G2].Resize(z) = WorksheetFunction.Transpose(Split(sq3, "|"))
End Sub

wiki · 11 jan 2011

voor wat inspiratie

Code:

Private Sub Workbook_Open()
Dim tijd As Integer, r As Long
On Error Resume Next
For r = 1 To Range("b65536").End(xlUp)
If Cells(r, 2) <> "" Then
tijd = Cells(r, 2) - Cells(1, 1)
MsgBox "Vervang hijskabels " & Cells(r, 1) & " over " & tijd & " dagen"
End If
Next
End Sub

gr wim

danny147 · 11 jan 2011

Beste Warme bakkertje ,zapatr en wiki,

Bedankt voor de suggesties.

Dat van warme bakkertje geeft je natuurlijk een beter overzicht van hetgeen moet uitgevoerd worden.

Dat van wiki was ook mijn eerste bedoeling.

Dat van zapatr is ook een mogelijkheid.

Als er nog suggesties zijn, dan hoor ik het graag.

Zal ze morgen eens grondig bestuderen.

Alvast bedankt :thumb:

Groetjes danny.v:thumb:

danny147 · 12 jan 2011

Beste Warme bakkertje ,zapatr en wiki

Heb het bestandje wat aangepast met alle 3 jullie voorstellen erin.

Bij de code van warme bakkertje krijg ik een foutmelding bij een bepaalde datum, zie bestandje.

Groetjes Danny. :thumb:

Warme bakkertje · 12 jan 2011

Ik heb er een nieuwe gemaakt, nu met een Listbox

danny147 · 12 jan 2011

Beste warme bakkertje,

Bedankt voor je voorstel, maar ik vond persoonlijk de vorige opgave interessanter voor mij.
De gegevens blijven op het blad staan en dat is wat ik zou willen.

Kan je de vorige opgave niet verwezenlijken, zodat het ook lukt als ik de datum van 22-1-2011 intyp in cel B4 ?

Groetjes Danny. :thumb:

Warme bakkertje · 12 jan 2011

Code:

Private Sub Workbook_Open()
On Error Resume Next
[E2:G20] = ""
For Each cl In [B4:B11]
    If cl <= [A1] + 7 Then
        sq = sq & cl.Offset(, -1) & "|"
    ElseIf cl <= [A1] + 14 And cl > [A1] + 7 Then
        sq2 = sq2 & cl.Offset(, -1) & "|"
    ElseIf cl <= [A1] + 30 And cl > [A1] + 14 Then
        sq3 = sq3 & cl.Offset(, -1) & "|"
    End If
Next
[E2].Resize(UBound(Split(sq, "|"))) = WorksheetFunction.Transpose(Split(sq, "|"))
[F2].Resize(UBound(Split(sq2, "|"))) = WorksheetFunction.Transpose(Split(sq2, "|"))
[G2].Resize(UBound(Split(sq3, "|"))) = WorksheetFunction.Transpose(Split(sq3, "|"))
If [E2] <> "" Then
MsgBox ("Er zijn DRINGEND hijskabels te vervangen !!!")
End If
If [E2] = "" And [F2] <> "" Then
MsgBox ("Er zijn hijskabels te vervangen binnen de 14 dagen !!!")
End If
If [E2] = "" And [F2] = "" And [G2] <> "" Then
MsgBox ("Er zijn hijskabels te vervangen binnen de maand !!!")
End If
End Sub

danny147 · 12 jan 2011

Beste warme bakkertje,

Bedankt Rudi voor de aanpassing van de code :thumb:

We zijn aan een project bezig op mijn werk om alles in goede banen te leiden.

Ik hoop op je diensten in de toekomst die ik zeker nog nodig zal hebben

Zal deze topic op opgelost plaatsen, nadien kan ik deze dan terug opvissen.

Groetjes Danny. :thumb:

Warme bakkertje · 13 jan 2011

Daarvoor zijn we er, nietwaar

Ik herinner me je eerste grote project nog (+100 posts), dus ik ben benieuwd :d

danny147 · 30 jan 2011

Hijskabels !

Beste warme bakkertje en anderen,

Heb al het een en ander in elkaar gestoken.

Beetje bij beetje komen we er wel.

In tabblad HO (Hoogovens) kan je op de knop lijst weergeven klikken.
Hier zou ik graag willen zien:

Bij 0% ------> LK20
Bij + 20% ---> LK21

Daarna op de knop "lijst wegschrijven", moet hij deze wegschrijven naar tabblad "wegschrijven" om nadien de gegevens af te printen, tenzij dit rechtstreeks kan via de userform, dat is nog beter zelfs.

De rest moet ik nog aanpassen.

In tabblad "inhoudtabel" staan een paar knoppen die ik later zal bespreken om deze dan ook op te vullen met codes.

Groetjes Danny. :thumb:

danny147 · 1 feb 2011

Beste,

Ik gebruik nu deze code in de Userform met half resultaat.

Code:

Private Sub userform_initialize()
On Error Resume Next
For Each cl In [P9:V41]
    If cl <= "OK" Then
        sq = sq & cl.Offset(-1, -14) & "|"
    ElseIf cl = " + 10% bereikt" Then
        sq2 = sq2 & cl.Offset(-1, -16) & "|"
    ElseIf cl = " + 20% bereikt" Then
        sq3 = sq3 & cl.Offset(-1, -18) & "|"
    ElseIf cl = " + 50% bereikt" Then
        sq4 = sq4 & cl.Offset(-1, -20) & "|"
    End If
Next
ReDim myArray(20, 4)
For i = 0 To UBound(Split(sq, "|"))
myArray(i, 0) = Split(sq, "|")(i)
Next i
For i = 0 To UBound(Split(sq2, "|"))
myArray(i, 1) = Split(sq2, "|")(i)
Next i
For i = 0 To UBound(Split(sq3, "|"))
myArray(i, 2) = Split(sq3, "|")(i)
Next i
For i = 0 To UBound(Split(sq4, "|"))
myArray(i, 3) = Split(sq4, "|")(i)
Next i
ListBox1.ColumnCount = 4
ListBox1.ColumnWidths = "80;80;80;80"
ListBox1.List = myArray
End Sub

Groetjes Danny. :thumb:

Warme bakkertje · 2 feb 2011

Wa peist ge hiervan ?

danny147 · 2 feb 2011

Beste Warme bakkertje,

Bedankt voor de snelle reactie.

Kan je ook eens kijken naar de kleuren in ThisWorkbook, dit werkt niet perfect.

Nu ga ik wat aanvullingen doen en de rest is voor dit weekend denk ik.

Groetjes Danny. :thumb:

Warme bakkertje · 3 feb 2011

Code:

Private Sub Workbook_sheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'http://www.mvps.org/dmcritchie/excel/colors.htm'
    Application.ScreenUpdating = False
    Dim cl As Range, myArr
    On Error Resume Next
    ReDim myArr(1 To 6) As String
    myArr = Array("HO", "STL", "KWA", "WWA", "ALD", "Alle loopkranen")
    For i = 0 To 5
        With Sheets(myArr(i))
            For Each cl In .Range("P8:V41")
                If IsError(cl) Then cl.Interior.ColorIndex = 36: GoTo vervolg
                Select Case cl.Value
                    Case "OK": cl.Interior.ColorIndex = 4
                    Case " + 10% bereikt": cl.Interior.ColorIndex = 44
                    Case " + 20% bereikt": cl.Interior.ColorIndex = 3
                    Case " + 50% bereikt": cl.Interior.ColorIndex = 9
                    Case "": cl.Interior.ColorIndex = 36
                End Select
vervolg:
            Next
        End With
    Next
    Application.ScreenUpdating = True
End Sub

danny147 · 4 feb 2011

Beste Warme bakkertje,

Als ik de code wil proberen, gaat dit niet.

Kan jij de code eens in het bestandje plaatsen en kijken of het bij jouw werkt ?

Groetjes Danny. :thumb:

Warme bakkertje · 4 feb 2011

in de titel achter sheetselectionchange staat nog een 1-tje. verwijder dit onmiddelijk (is nog van testen, vergeten te verwijderen

)
heb de code aangepast in vorige post

danny147 · 6 feb 2011

Beset Warme bakkertje,

Bedankt voor het antwoord.

Het duurt een poosje vooralleer hij alles kleurt. (in mijn bestand dan wel)

Is dit omdat hij alle tabbladen telkens bekijkt.

Kan het ook met ActiveSheet ?

Groetjes Danny. :thumb:

Warme bakkertje · 6 feb 2011

Code:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'http://www.mvps.org/dmcritchie/excel/colors.htm'
    Application.ScreenUpdating = False
    Dim cl As Range
    On Error Resume Next
    If Not Sh.Name = "Blad1" And Not Sh.Name = "Inhoudstabel" And Not Sh.Name = "Wegschrijven" Then
        With Sh
            For Each cl In .Range("P8:V169")
                If IsError(cl) Then cl.Interior.ColorIndex = 36: GoTo vervolg
                Select Case cl.Value
                    Case "OK": cl.Interior.ColorIndex = 4
                    Case " + 10% bereikt": cl.Interior.ColorIndex = 44
                    Case " + 20% bereikt": cl.Interior.ColorIndex = 3
                    Case " + 50% bereikt": cl.Interior.ColorIndex = 9
                    Case "": cl.Interior.ColorIndex = 36
                End Select
vervolg:
            Next
        End With
     End If
    Application.ScreenUpdating = True
End Sub

Melding met MsgBox als datum bijna bereikt is.

Terugkerende gebruiker

Bijlagen

Terugkerende gebruiker

Meubilair

Gebruiker

Terugkerende gebruiker

Terugkerende gebruiker

Bijlagen

Meubilair

Bijlagen

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Bijlagen

Terugkerende gebruiker

Bijlagen

Meubilair

Bijlagen

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Terugkerende gebruiker

Meubilair

Wij waarderen jouw privacy