VBA Array problems

[NatWally]

Hi there,

I have been having problems with my arrays in several of my sheets.
The array doesn't seem to hold all the information, and sometimes it also doesn't show the full text I want it to.
I am adding new columns into the sheets, and then changing the vba to match the correct column but it still doesn't seem to work correctly.
I am not sure if the array size is limited or anything which could be causing the problem.
It used to work fine at the start, but of course over time the individual sheets will become more populated with date and so the array may not function correctly.

Unfortunately, I am not exactly sure how to show you as I cannot attached the Excel spre
Please test the macro buttons on sheet 2, 3, 4, and 7 and you will see what I mean. Obviously feel free to investigate the vba code behind them to see why the problem is occurring for all of them.
As I can't attach anything, I am hoping this link works successfully: https://drive.google.com/file/d/1N6sYc5VxVk79MPRRJcG2pLc-JaCheS57/view?usp=sharing

If you need further information on what they are supposed to be doing or anything, please let me know.

Thank you.

 

[JackDanIce]

The MsgBox has a limit of 1024 characters. You can adjust the array size as much as you like, it won't physically increase the character count of the msgbox.

Hence @Fluff's comment

You are hitting the limit of what you can enter in a msgbox.

and why I split it into 3 msgbox's so you have 3x 1024 chars to display not 1x 1024 chars. This is why I reduced the amount of text you were displaying as it was erroneous.

And my comment which seems to have been ignored:

It does seem to be a character string limit. I've separated the msgbox into 3 separate msgbox's plus included a warning if the string length is too big for the msgbox. Line in red is where this test occurs

Does it not make sense? The length of the string you are passing to the msgbox bigger than the maximum limit of msgbox so the msgbox won't show something bigger than it can handle. Increasing the string size won't help, your problem has nothing to do with array sizing.

You are trying to force a size twelve foot into a size 1 shoe. Increasing the foot size won't solve the problem.

 

[NatWally]

I misunderstood.
I increased the 1024, to tes tif the msgbox for SAFEGUARDING TRAINING NOT COMPLETED FOR (Start Date) would at least come up/work, which it did.

However, it is still not quite right as it is not doing the right thing - it needs to display those that have a first name and/or surname, but no date in any one of the two boxes.
Is there also anything for if everything is right - i.e. no missing date, no expired or expiring date, and no missing name? (as there was previously)

 

[JackDanIce]

I suggested 3 private functions for the main procedure. You can edit the 3rd private function for safeguard training not completed to return the message exactly as you need.

This is what was said earlier, there is far too much to fix. What I suggested should only break apart the different sections of the existing macro to make specific edits easier. Please go back and review.

Your initial problem is "VBA array sizing not working" Fluff and I both believe it's NOT an array issue but a msgbox size limit issue.

I've rewritten your code and re-iterated the problem is not to do with array sizing and tried to reduce the count of characters each function returns as a string to display in the msgbox.

As Fluff suggested, reduce the amount of characters you want to display in a msgbox OR use a UserForm for less restrictions on string length and display how you want.

 

[Fluff]

With your original code, without the boilers

Sub ExpireS()

 Const LDays As Integer = 31
Dim LDiff As Long, i As Long
Dim tempArr, LResponse
Dim willExp As String, hasExp As String, noSafeG As String
With Sheets("Support staff")
    tempArr = .Range("A21:Z" & .Cells(Rows.Count, "S").End(xlUp).Row).Value
End With

For i = LBound(tempArr) To UBound(tempArr)
    If Len(tempArr(i, 19)) > 0 And Len(tempArr(i, 1)) > 0 And Len(tempArr(i, 2)) > 0 Then
        LDiff = DateDiff("d", Date, tempArr(i, 19))
        If LDiff >= 0 And LDiff <= LDays Then
            willExp = IIf(Len(willExp) = 0, "EXPIRING" & vbNewLine & _
             tempArr(i, 1) & " " & _
            tempArr(i, 2) & " expires in " & LDiff & " days (" & tempArr(i, 19) & ")" & vbNewLine, willExp & _
                  tempArr(i, 1) & " " & _
            tempArr(i, 2) & " expires in " & LDiff & " days (" & tempArr(i, 19) & ")" & vbNewLine)
        End If
        If LDiff < 0 Then
           hasExp = IIf(Len(hasExp) = 0, "EXPIRED" & vbNewLine & _
             tempArr(i, 1) & " " & _
            tempArr(i, 2) & ", " & tempArr(i, 19) & vbNewLine, hasExp & _
            tempArr(i, 1) & " " & _
            tempArr(i, 2) & ", " & tempArr(i, 19) & vbNewLine)
        End If
    ElseIf Len(tempArr(i, 19)) = 0 And Len(tempArr(i, 1)) > 0 And Len(tempArr(i, 2)) > 0 Then
        noSafeG = IIf(Len(noSafeG) = 0, "NO SAFEGUARDING TRAINING" & vbNewLine & _
        tempArr(i, 1) & " " & _
        tempArr(i, 2) & " " & " (" & tempArr(i, 18) & ")" & vbNewLine, noSafeG & _
        tempArr(i, 1) & " " & _
        tempArr(i, 2) & " " & " (" & tempArr(i, 18) & ")" & vbNewLine)
    End If
Next

If Len(willExp & hasExp & noSafeG) = 0 Then
    LResponse = MsgBox("There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning")
Else
    LResponse = MsgBox(willExp & String(40, "=") & vbNewLine & hasExp & String(40, "=") & vbNewLine & noSafeG)
End If
            
End Sub

Does this do what you want?

 

[NatWally]

Thanks for all your help so far guys.

I have had a little tinker with it to try and get it to what we need, there is just one issue still.
All code is below:

Sub Expire_New()

    Dim arr()       As Variant
    Dim msg(1 To 4) As String
    Dim x           As Long
    Dim dDiff       As Long
    
    With ActiveSheet
        x = .Cells(.Rows.Count, 19).End(xlUp).Row
        arr = .Cells(21, 1).Resize(x - 20, 26).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        If Len(arr(x, 19)) * Len(arr(x, 1)) * Len(arr(x, 2)) Then
            dDiff = DateDiff("d", Date, arr(x, 19))
            Select Case dDiff
                Case Is <= 0: msg(1) = Expired(msg(1), arr(x, 1), arr(x, 2), arr(x, 19))
                Case Is <= 31: msg(2) = Expiring(msg(2), arr(x, 1), arr(x, 2), arr(x, 19), dDiff)
            End Select
        End If
    
    If Len(arr(x, 19)) = 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
             msg(3) = NoTraining(msg(3), arr(x, 1), arr(x, 2), arr(x, 18))
        End If
        
    If Len(arr(x, 19)) > 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
    dDiff = DateDiff("d", Date, arr(x, 19))
        Select Case dDiff
         Case Is > 31: msg(4) = MsgBox("There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning")
        End Select
    End If
    
    Next x
    
    For x = LBound(msg) To UBound(msg)
        msg(x) = Replace(msg(x), "@NL", vbCrLf)
        If Len(msg(x)) < 1024 Then
            MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
        Else
            MsgBox "String length for notification too long to fit into this MessageBox", vbExclamation, "Invalid String Length to Display"
        End If
    Next x
    
    Erase arr
    Erase msg
    
End Sub


Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant) As String


    If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading Certificates@NL@NL"
    
    Expired = msg & "(@var3) @var1 @var2@NL"
    Expired = Replace(Expired, "@var1", var1)
    Expired = Replace(Expired, "@var2", var2)
    Expired = Replace(Expired, "@var3", var3)
    
End Function


Private Function Expiring(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant, ByRef d As Long) As String
    
    If Len(msg) = 0 Then msg = "Persons with EXPIRING Safeguarding Certificates@NL@NL"
            
    Expiring = msg & "(@var3) @var1 @var2 (@d days remaining)@NL"
    Expiring = Replace(Expiring, "@var1", var1)
    Expiring = Replace(Expiring, "@var2", var2)
    Expiring = Replace(Expiring, "@var3", var3)
    Expiring = Replace(Expiring, "@d", d)
    
End Function


Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant) As String
    
    If Len(msg) = 0 Then msg = "SAFEGUARDING TRAINING NOT COMPLETED FOR @NL@NL"
            
    NoTraining = msg & " @var1 @var2@NL"
    NoTraining = Replace(NoTraining, "@var1", var1)
    NoTraining = Replace(NoTraining, "@var2", var2)
    NoTraining = Replace(NoTraining, "@var3", var3)
    
End Function

Currently with this code, the Expired, Expiring, and No Training all work correctly. It is the section where I need it to come up with just one message box if there are always names in 1 and 2, and there is always a date over the 31 day difference between current day and expired date. So basically, this is the only message that should come up if everyone has a name and isn't expiring or expired. Currently it comes up for everyone that has a valid date and name (I am assuming this is happening because it is part of the array and so will come up for anything in the array that satisfies it). At the end there is also a random box with a '1' in it.
This is the section of the above code that I think it wrong and also wrongly placed. Does it need to be placed outside of the main array?

  If Len(arr(x, 19)) > 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then 'if there is always a date, and two names   dDiff = DateDiff("d", Date, arr(x, 19))
        Select Case dDiff
         Case Is > 31: msg(4) = MsgBox("There are either no expired safeguarding certificates, or no certificate expiring within the next 31 days.", vbCritical, "Warning") 'if the difference is more than 31 days
        End Select
    End If

Thank you.

 

[NatWally]

Is anyone able to help with the above please?!?

 

[NatWally]

So is no one able to help? All it needs is a msg to say that if there are names in 1 and 2, and the date in 19 is not expired, expiring, or non-existent, then everything is fine. If this box comes up then none of the others should.
This is the code so far:

Sub Expire_New()

    Dim arr()       As Variant
    Dim msg(1 To 3) As String
    Dim x           As Long
    Dim dDiff       As Long
    
    With ActiveSheet
        x = .Cells(.Rows.Count, 19).End(xlUp).Row
        arr = .Cells(21, 1).Resize(x - 20, 26).Value
    End With
    
    For x = LBound(arr, 1) To UBound(arr, 1)
        If Len(arr(x, 19)) * Len(arr(x, 1)) * Len(arr(x, 2)) Then
            dDiff = DateDiff("d", Date, arr(x, 19))
            Select Case dDiff
                Case Is < 0: msg(1) = Expired(msg(1), arr(x, 1), arr(x, 2), arr(x, 19))
                Case Is <= 31: msg(2) = Expiring(msg(2), arr(x, 1), arr(x, 2), arr(x, 19), dDiff)
            End Select
        End If
    If Len(arr(x, 19)) = 0 And Len(arr(x, 1)) > 0 And Len(arr(x, 2)) > 0 Then
             msg(3) = NoTraining(msg(3), arr(x, 1), arr(x, 2), arr(x, 18))
        End If
        
    Next x
    
    For x = LBound(msg) To UBound(msg)
        msg(x) = Replace(msg(x), "@NL", vbCrLf)
        If Len(msg(x)) < 1024 Then
            MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
        Else
            MsgBox "String length for notification too long to fit into this MessageBox", vbExclamation, "Invalid String Length to Display"
        End If
    Next x
    
    Erase arr
    Erase msg
    
End Sub


Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant) As String


    If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading Certificates@NL@NL"
    
    Expired = msg & "(@var3) @var1 @var2@NL"
    Expired = Replace(Expired, "@var1", var1)
    Expired = Replace(Expired, "@var2", var2)
    Expired = Replace(Expired, "@var3", var3)
    
End Function


Private Function Expiring(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant, ByRef d As Long) As String
    
    If Len(msg) = 0 Then msg = "Persons with EXPIRING Safeguarding Certificates@NL@NL"
            
    Expiring = msg & "(@var3) @var1 @var2 (@d days remaining)@NL"
    Expiring = Replace(Expiring, "@var1", var1)
    Expiring = Replace(Expiring, "@var2", var2)
    Expiring = Replace(Expiring, "@var3", var3)
    Expiring = Replace(Expiring, "@d", d)
    
End Function


Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant, ByRef var2 As Variant, ByRef var3 As Variant) As String
    
    If Len(msg) = 0 Then msg = "SAFEGUARDING TRAINING NOT COMPLETED FOR (Start Date)@NL@NL"
            
    NoTraining = msg & "(@var3) @var1 @var2@NL"
    NoTraining = Replace(NoTraining, "@var1", var1)
    NoTraining = Replace(NoTraining, "@var2", var2)
    NoTraining = Replace(NoTraining, "@var3", var3)
    
End Function