Create a list in a message box

[bayles]

Hi,

I am trying to create a msgbox that has a list of items.

I have values in a column E. If the value in this column is greater than 1 I would like to take the information from columns B, C, D of the same row.

There might be no lines where the value is greater than 1 and there might be more than 20 which means I would need a second msgbox.

Below is code I am trying to adapt which works well in other workbooks I use. It has been corrupted by me playing around on it so pay it no attention other than the general direction I am trying to go.

Any help appreciated.

Thanks


Sub PAGES()



Cells.Select
Rows.Hidden = False
Dim PageCount(), Descr(), Page(), Price() As Long, lMax As Long, lNoRows As Long, i As Long
Dim Rng As Range
Dim sMsg As String
Const MAX_TO_SHOW = 10000

ReDim PageCount(1 To MAX_TO_SHOW)
Set Rng = Range(Cells.Find(What:="MULTIBUY QTY", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(1, 0), Cells.Find(What:="MULTIBUY QTY", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(10000).End(xlUp))

Cells.Find(What:="MULTIBUY QTY", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(1, 0).Select

lNoRows = Application.WorksheetFunction.CountIf(Rng, ">1")

For i = 1 To UBound(PageCount)
If Cells(i + 1, ActiveCell.Column) > 1 Then

Descr(i) = Cells(i + 1, 2).Value
Page(i) = Cells(i + 1, 3)
Price(i) = Cells(i + 1, 5) & " for $" & Cells(i, 4) * Cells(i + 1, 5)
Else
If lCount = lNoRows Then Exit For
End If
Next i

If i > UBound(PageCount) Then
lMax = i - 1
Else
lMax = i
End If


sMsg = "Description Page No: Multibuy Value"
For i = 1 To 20
If PageCount(i) > 0 Then 'optional
sMsg = sMsg & vbNewLine & " " & i & " " & PageCount(i)
End If 'optional
Next i
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
MsgBox sMsg, , "NUMBER OF FEATURES PER PAGE"

sMsg2 = "Page No: Number of Features"
If Application.WorksheetFunction.Max(Range("B10:B10000")) > 20 Then
For i = 21 To 40
If PageCount(i) > 0 Then 'optional
sMsg2 = sMsg2 & vbNewLine & " " & i & " " & PageCount(i)
End If 'optional
Next i
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
MsgBox sMsg2, , "NUMBER OF FEATURES PER PAGE"
End If

sMsg3 = "Page No: Number of Features"
If Application.WorksheetFunction.Max(Range("B10:B10000")) > 40 Then
For i = 41 To 60
If PageCount(i) > 0 Then 'optional
sMsg = sMsg3 & vbNewLine & " " & i & " " & PageCount(i)
End If 'optional
Next i
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
MsgBox sMsg3, , "NUMBER OF FEATURES PER PAGE"
End If



End Sub

 

[StephenCrump]

Below is code I am trying to adapt which works well in other workbooks I use. It has been corrupted by me playing around on it so pay it no attention other than the general direction I am trying to go.

Hmm, this looks vaguely familiar: http://www.mrexcel.com/forum/excel-questions/841771-message-box-dynamic-content.html

? I'm guessing that your general direction is something like this at its simplest:

Sub ShowValues()

    Dim vValues As Variant
    Dim sMsg As String
    Dim lcount As Long, i As Long
    Const MAX_TO_SHOW = 20
    
    vValues = Range("B1:E" & Range("E" & Rows.Count).End(xlUp).Row).Value
        
    sMsg = "Rows where Column E > 1:"
    For i = 1 To UBound(vValues, 1)
        If vValues(i, 4) > 1 Then _
            lcount = lcount + 1
            sMsg = sMsg & vbNewLine & vValues(i, 1) & " " & vValues(i, 2) & vValues(i, 3)
            If lcount = MAX_TO_SHOW Then Exit For
    Next i
    
    MsgBox sMsg

End Sub

What do you want to do after 20? Keep providing message boxes until the user says stop?

 

[bayles]

Thanks Stephen.

What if there was 200 rows but there was only 2 instances where E > 1, how would I not have all the blank spaces between the results?

 

[StephenCrump]

Oops sorry, the IF() block should have been:

        If vValues(i, 4) > 1 Then
            lcount = lcount + 1
            sMsg = sMsg & vbNewLine & vValues(i, 1) & " " & vValues(i, 2) & vValues(i, 3)
            If lcount = MAX_TO_SHOW Then Exit For
        End If

 

[bayles]

Hi Stephen,

Great! That looks like it is working now.

Two more questions:
1. How would I amend the code if the results exceed the character limitation of the message box?

2. Any tips on spacing the values apart as the length of each cell value varies.

Thanks

 

[StephenCrump]

1. How would I amend the code if the results exceed the character limitation of the message box?

2. Any tips on spacing the values apart as the length of each cell value varies.

1. I wouldn't use message boxes myself to show large amounts of information. Depending on what you're trying to achieve, alternative methods would include:

a) Using conditional formatting to highlight the "discrepancies".

b) Have the message box say : There are more than n discrepancies, here are the first n: ..."

c) Write all the discrepancies to a debug sheet in the workbook, or create a separate debug report.

2. You can use vbTab rather than " " to separate the values, and also Format() the values. This will improve the alignment, but I doubt you'll make it perfect.

 

[bayles]

Hi Stephen,

Thanks again for the suggestions.

Here is my final code which appears to be working. the text in the first column can range from a Len of 10 to 50 so I just limited it to 20 characters and played around with vbtab. I also did a check on the len of the sMsg and when it exceeded 900 characters I would create a second msgbox. If it was less than 1000 then just the one msgbox would be shown.

It might not be perfect in code or on screen always but serves it purpose.

Thanks

Sub CHECK_MULTIS()


Dim vValues As Variant
Dim sMsg As String
Dim lcount As Long, i As Long

vValues = Range(Cells.Find(What:="MULTIBUY QTY", After:=Range("A1"), LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(0, -3), Cells(Cells.Find(What:="MULTIBUY QTY", After:=Range("A1"), LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(10000, 0).End(xlUp).Row, Cells.Find(What:="MULTIBUY QTY", After:=Range("A1"), LookIn:=xlValues, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Column))

sMsg = "Description" & vbTab & vbTab & vbTab & "Page No:" & vbTab & "Multibuy Value"
For i = 2 To UBound(vValues, 1)


If vValues(i, 4) > 1 Then
lcount = lcount + 1
If Len(vValues(i, 1)) < 20 Then
sMsg = sMsg & vbNewLine & Left(vValues(i, 1), 20) & "...." & vbTab & vbTab & vbTab & vValues(i, 2) & vbTab & vValues(i, 4) & " for $" & Round(vValues(i, 3) * vValues(i, 4), 2)
Else
sMsg = sMsg & vbNewLine & Left(vValues(i, 1), 20) & "...." & vbTab & vbTab & vValues(i, 2) & vbTab & vValues(i, 4) & " for $" & Round(vValues(i, 3) * vValues(i, 4), 2)
End If
If Len(sMsg) > 900 Then
msg = MsgBox(sMsg, vbOKCancel, "CHECK MULTIBUYS")
If msg = vbCancel Then
End
End If
sMsg = "Description" & vbTab & vbTab & vbTab & "Page No:" & vbTab & "Multibuy Value"
End If
End If


Next i

msg = MsgBox(sMsg, vbOKCancel, "CHECK MULTIBUYS")



End Sub

 

[StephenCrump]

You're welcome. I'm glad you got your code working.