vba macro display result of loop to msgbox - vba

I creted a loop checking number of characters length with conditions but sadly it's not properly working,
with approriate no. of loops but not reading the next line, I want to post the result in a MsgBox,
but when I use the msgbox inside the loop I will get a msgbox for every result found or only one msgbox with one result.
What I would like is to display every result in 1 msgbox with a line vbNewLine after each result.
Below is my code:
Public Sub Rs()
Dim Text As String
Dim NumChar As String
Dim i As Integer
Dim NumRows As Long
Application.ScreenUpdating = False
'Get Cell Value
Text = Range("B2").Value
'Get Char Length
NumChar = Len(Text)
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
For i = 1 To NumRows
'Character length validation
If Len(Text) <= 15 Then
MsgBox Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and it's Valid !" & vbNewLine
Else
MsgBox Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and Exceeded allowable number of characters!" & vbNewLine
End If
Next i
Application.ScreenUpdating = True
End Sub

Assign the new text to a string variable and display the string variable outside the loop:
Option Explicit
Sub TestMe()
Dim i As Long
Dim displayText As String
For i = 1 To 3
displayText = displayText & vbCrLf & i
Next i
MsgBox displayText
End Sub

Build a string through concatenation and display the strings after exiting the loop.
Public Sub Rs()
Dim Text As String
Dim NumChar As String
Dim i As Integer
Dim NumRows As Long
dim msg1 as string, msg2 as string
Application.ScreenUpdating = False
'Get Cell Value
Text = Range("B2").Value
'Get Char Length
NumChar = Len(Text)
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
For i = 1 To NumRows
'Character length validation
If Len(Text) <= 15 Then
msg1 = msg1 & Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and it's Valid !" & vbLF
Else
msg2 = msg2 & Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and Exceeded allowable number of characters!" & vbLF
End If
Next i
Application.ScreenUpdating = True
if cbool(len(msg1)) then
msg1 = left(msg1, len(msg1)-1)
MsgBox msg1
end if
if cbool(len(msg2)) then
msg2 = left(msg2, len(msg2)-1)
MsgBox msg2
end if
End Sub
A MsgBox uses Chr(10) aka vbLF for new lines; vbNewLine is overkill.

Related

Content Control not recognizing content

I was hoping someone could help me work out why the the 'F' value in my code below continues to include my error label in the ErrorMessage String when the Count value is 5?
In the document, the content control contains text just like all the other controls (which work perfectly) but this content Control text value is not being recognised in the VBA code to map error labels.
Have tried just replacing the control and checking the properties match. Debug messages suggest the the value is just being set to the default Content Control Value of "Click or Tap here to input text".
Private Sub Create_Click()
Dim oCC As ContentControl
Dim oCC2 As ContentControl
Dim Mandatory(9) As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim ErrorLabel(9) As String
Dim objDoc As Document
Dim strFilename As String
Dim strFileString As String
Dim Number As String
Mandatory(0) = "A"
Mandatory(1) = "B"
Mandatory(2) = "C"
Mandatory(3) = "D"
Mandatory(4) = "E"
Mandatory(5) = "F"
Mandatory(6) = "G"
Mandatory(7) = "H"
Mandatory(8) = "I"
ErrorLabel(0) = "A Label"
ErrorLabel(1) = "B Label"
ErrorLabel(2) = "C Label"
ErrorLabel(3) = "D Label"
ErrorLabel(4) = "E Label"
ErrorLabel(5) = "F Label"
ErrorLabel(6) = "G Label"
ErrorLabel(7) = "H Label"
ErrorLabel(8) = "I Label"
ErrorMessage = ""
ErrorMessage = "The following mandatory fields are missing: "
For Count = 0 To 8
Set oCC = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1)
MsgBox (oCC.Range.Text)
If Count = 0 Then
Number = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1).Range.Text
End If
If oCC.Range.Text = "Click or tap here to enter text." Or oCC.Range.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & ErrorLabel(Count)
MsgBox (oCC.Range.Text)
ErrorCount = ErrorCount + 1
End If
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With ActiveDocument
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
End With
End If
End Sub
Check there are no other content controls with the same title in the document.
I couldn't test your code for lack of data but from your description I guess that the ErrorMessage must be reset with each loop since it will be changed when used and would naturally retain the modified version thereafter.
Except for what follows the loop, I looked closely at your code in order to understand it. Perhaps, the changes I made will be of some use to you.
Option Explicit
Private Sub Create_Click()
Dim Doc As Document
Dim Mandatory() As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim strFilename As String
Dim strFileString As String ' this appears identical with 'Number'
Dim Number As String
Dim Count As Integer ' loop counter
Set Doc = ActiveDocument
Mandatory = Split("A B C D E F G H I")
Number = Doc.SelectContentControlsByTitle(Mandatory(0))(1).Range.Text
For Count = 1 To UBound(Mandatory) + 1
ErrorMessage = "The following mandatory fields are missing: "
With Doc.SelectContentControlsByTitle(Mandatory(Count))(1).Range
MsgBox "Number = " & Number & vbCr & .Text
If .Text = "Click or tap here to enter text." Or _
.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & Mandatory(Count) & " Label"
MsgBox (.Text)
ErrorCount = ErrorCount + 1
End If
End With
If Count = 1 Then Exit For
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With Doc
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent
End With
End If
End Sub
You can have VBA add the useful (some would say necessary) Option Explicit to all new code modules automatically. Select Tools > Options in the VBE window and check "Require Variable Declaration" on the Editor tab.

List FormatConditions of all controls on an Access form

Is it possible to list the conditional formatting of all controls on a form? I'd like to be able to list out all existing conditions so that I can generate code to add/remove the existing conditions. I have inherited some complex forms and want to know what I'm dealing with and then generate some code to toggle the conditional formatting in areas where it is slowing down navigating a continuous form.
This Excel VBA example shows a similar format I'd like to have for Access.
https://stackoverflow.com/a/52204597/1898524
Only textboxes and comboboxes have Conditional Formatting.
There is no single property that can be listed to show a control's conditional formatting rule(s). Each rule has attributes that can be listed. Example of listing for a single specific control:
Private Sub Command25_Click()
Dim x As Integer
With Me.tbxRate
For x = 0 To .FormatConditions.Count - 1
Debug.Print .FormatConditions(x).BackColor
Debug.Print .FormatConditions(x).Expression1
Debug.Print .FormatConditions(x).FontBold
Next
End With
End Sub
The output for this example:
2366701
20
False
These are attributes for a rule that sets backcolor to red when field value is greater than 20.
Yes, code can loop through controls on form, test for textbox and combobox types, determine if there are CF rules and output attributes.
With some inspiration from #June7's example and some code from an article I found by Garry Robinson, I wrote a procedure that answers my question.
Here's the output in the Immediate window. This is ready to be pasted into a module. The design time property values are shown as a comment.
txtRowColor.FormatConditions.Delete
txtRowColor.FormatConditions.Add acExpression, acBetween, "[txtCurrent_Equipment_List_ID]=[txtEquipment_List_ID]"
With txtRowColor.FormatConditions.Item(txtRowColor.FormatConditions.Count-1)
.Enabled = True ' txtRowColor.Enabled=False
.ForeColor = 0 ' txtRowColor.ForeColor=-2147483640
.BackColor = 10092543 ' txtRowColor.BackColor=11850710
End With
You can test this sub from a click event on an open form. I was getting some false positives when checking the Boolean .Enabled property, even when I store the values into Boolean variables first. I don't know why and am researching it, but that is beyond the scope of this question.
Public Sub ListConditionalFormats(frmForm As Form)
' Show all the Textbox and Combobox controls on the passed form object (assuming the form is open).
' Output the FormatCondtion properties to the immediate window in a format that is
' suitable to be copied into VBA to recreate the conditional formatting.
' The design property value is shown as a comment on each condition property row.
Dim ctl As Control
Dim i As Integer
Dim bolControlEnabled As Boolean
Dim bolFormatEnabled As Boolean
On Error GoTo ErrorHandler
For Each ctl In frmForm.Controls
If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Then
With ctl
If .FormatConditions.Count > 0 Then
'Debug.Print vbCr & "' " & ctl.Name, "Count = " & .FormatConditions.Count
For i = 0 To .FormatConditions.Count - 1
' Generate code that can recreate each FormatCondition
Debug.Print ctl.Name & ".FormatConditions.Delete"
Debug.Print ctl.Name & ".FormatConditions.Add " & DecodeType(.FormatConditions(i).Type) _
& ", " & DecodeOp(.FormatConditions(i).Operator) _
& ", """ & Replace(.FormatConditions(i).Expression1, """", """""") & """" _
& IIf(Len(.FormatConditions(i).Expression2) > 0, ", " & .FormatConditions(i).Expression2, "")
Debug.Print "With " & ctl.Name & ".FormatConditions.Item(" & ctl.Name & ".FormatConditions.Count-1)"
bolControlEnabled = ctl.Enabled
bolFormatEnabled = .FormatConditions(i).Enabled
'Debug.Print bolControlEnabled <> bolFormatEnabled, bolControlEnabled, bolFormatEnabled
If bolControlEnabled <> bolFormatEnabled Then ' <- This sometimes fails. BS 2/9/2020
'If ctl.Enabled <> .FormatConditions(i).Enabled Then ' <- This sometimes fails. BS 2/9/2020
Debug.Print vbTab & ".Enabled = " & .FormatConditions(i).Enabled; Tab(40); "' " & ctl.Name & ".Enabled=" & ctl.Enabled
End If
If ctl.ForeColor <> .FormatConditions(i).ForeColor Then
Debug.Print vbTab & ".ForeColor = " & .FormatConditions(i).ForeColor; Tab(40); "' " & ctl.Name & ".ForeColor=" & ctl.ForeColor
End If
If ctl.BackColor <> .FormatConditions(i).BackColor Then
Debug.Print vbTab & ".BackColor = " & .FormatConditions(i).BackColor; Tab(40); "' " & ctl.Name & ".BackColor=" & ctl.BackColor
End If
If ctl.FontBold <> .FormatConditions(i).FontBold Then
Debug.Print vbTab & ".FontBold = " & .FormatConditions(i).FontBold; Tab(40); "' " & ctl.Name & ".FontBold=" & ctl.FontBold
End If
If ctl.FontItalic <> .FormatConditions(i).FontItalic Then
Debug.Print vbTab & ".FontItalic = " & .FormatConditions(i).FontItalic; Tab(40); "' " & ctl.Name & ".FontItalic=" & ctl.FontItalic
End If
If ctl.FontUnderline <> .FormatConditions(i).FontUnderline Then
Debug.Print vbTab & ".FontUnderline = " & .FormatConditions(i).FontUnderline; Tab(40); "' " & ctl.Name & ".FontUnderline=" & ctl.FontUnderline
End If
If .FormatConditions(i).Type = 3 Then ' acDataBar
Debug.Print vbTab & ".LongestBarLimit = " & .FormatConditions(i).LongestBarLimit
Debug.Print vbTab & ".LongestBarValue = " & .FormatConditions(i).LongestBarValue
Debug.Print vbTab & ".ShortestBarLimit = " & .FormatConditions(i).ShortestBarLimit
Debug.Print vbTab & ".ShortestBarValue = " & .FormatConditions(i).ShortestBarValue
Debug.Print vbTab & ".ShowBarOnly = " & .FormatConditions(i).ShowBarOnly
End If
Debug.Print "End With" & vbCr
Next
End If
End With
End If
Next
Beep
Exit_Sub:
Exit Sub
ErrorHandler:
MsgBox "Error #" & Err.Number & " - " & Err.Description & vbCrLf & "in procedure ListConditionalFormats" _
& IIf(Erl > 0, vbCrLf & "Line #: " & Erl, "")
GoTo Exit_Sub
Resume Next
Resume
End Sub
Function DecodeType(TypeProp As Integer) As String
' You heed this are there are 4 different ways to setup a CondtionalFormat
' https://vb123.com/listing-conditional-formats
Select Case TypeProp
Case 0
DecodeType = "acFieldValue"
Case 1
DecodeType = "acExpression"
Case 2
DecodeType = "acFieldHasFocus"
Case 3
DecodeType = "acDataBar"
End Select
End Function
Function DecodeOp(OpProp As Integer) As String
' You need this becuase equations can comprise of = > <> between
' https://vb123.com/listing-conditional-formats
Select Case OpProp
Case 0
DecodeOp = "acBetween"
Case 1
DecodeOp = "acNotBetween"
Case 2
DecodeOp = "acEqual"
Case 3
DecodeOp = "acNotEqual"
Case 4
DecodeOp = "acGreaterThan"
Case 5
DecodeOp = "acLessThan"
Case 6
DecodeOp = "acGreaterThanOrEqual"
Case 7
DecodeOp = "acLessThanOrEqual"
End Select
End Function

Excel Application Crash due to Macro

During launching my macro the Excel application is crashed. If I test the macro with an integer the program runs properly (partnumber = 123). If I check with a string the application is crashed. Thus, no error code is visible for me. I assume that there is a type mismatch (but I set Variant for partnumber)
Sub SbIsInCOPexport()
Dim lastRow As Long
Dim i As Long
Dim found As Boolean
Dim partnumber As Variant
i = 1
found = False
partnumber = ActiveCell.Value
Windows("COPexport.xlsx").Activate
lastRow = Sheets(1).Cells.SpecialCells(xlLastCell).Row
Do While i < lastRow + 1
If Cells(i, 6).Value = partnumber Then
found = True
Exit Do
End If
i = i + 1
Loop
If found = True Then
Cells(i, 6).Select
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & "Found part number: " _
& ActiveCell.Value & vbNewLine & "Address: " & Cells(i, 6).Address & vbNewLine & vbNewLine & "Test Order: " & _
Cells(i, 2).Value)
Windows("COPexport.xlsx").Activate
Else
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
End If
End Sub
What can be the root cause?
I don't see any obvious issues, but consider using the .Find method of range object, like so:
Sub SbIsInCOPexport()
Dim partnumber as Variant
Dim rng as Range
Windows("COPexport.xlsx").Activate
partnumber = ActiveCell.Value
Set rng = Columns(6).Find(partnumber) '## Search in column 6 for partnumber
If rng Is Nothing Then
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
Else
With rng
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & _
"Found part number: " & .Value & vbNewLine & _
"Address: " & .Address & vbNewLine & vbNewLine & _
"Test Order: " & .Offset(0,-4).Value) '## Get the value from column 2
End With
End If
End Sub

Crop last N lines of a string to display in userform textbox

I want to display a textlog string in a userform's textbox.
Code might look like this:
Dim public textlog as string
sub button1_click()
' do some action
textlog = textlog & event_string & vbCrLf
'event_string might exceed more than 2 line
textlog = textlog & "button1 action" & vbCrLf
userform1.textbox1.text = textlog
end sub
sub button2_click()
' do some action
textlog = textlog & event_string & vbCrLf
'event_string might exceed more than 2 line
textlog = textlog & "button2 action" & vbCrLf
userform1.textbox1.text = textlog
end sub
However, the textbox should only contain 20 lines of information, while my
the contents of my textlog will exceed 20 lines.
How can I display only the latest (last) 20 lines of the textlog in textbox1?
You can use this function to return only the last N lines of a string, and then display that in your textbox.
Note that you have to specify what the line break character is. Depending on your specific application, it could be vbCrLf, vbCr, vbLf, or even some other delimiter.
Function GetLastLines(ByVal s As String, ByVal nLinesToDisplay As Long, _
Optional ByVal lineBreakChar As String = vbCrLf)
'Split the string into an array
Dim splitString() As String
splitString = Split(s, lineBreakChar)
'How many lines are there?
Dim nLines As Long
nLines = UBound(splitString) + 1
If nLines <= nLinesToDisplay Then
'No need to remove anything. Get out.
GetLastLines = s
Exit Function
End If
'Collect last N lines in a new array
Dim lastLines() As String
ReDim lastLines(0 To nLinesToDisplay - 1)
Dim i As Long
For i = 0 To UBound(lastLines)
lastLines(i) = splitString(i + nLines - nLinesToDisplay)
Next i
'Join the lines array into a single string
GetLastLines = Join(lastLines, lineBreakChar)
End Function
Example usage:
MsgBox GetLastLines( _
"line 1" & vbCrLf & "line 2" & vbCrLf & "line 3" & vbCrLf _
& "line 4" & vbCrLf & "line 5" & vbCrLf & "line 6", _
4, vbCrLf)
Only the last 4 lines are displayed:
Note that this assumes that your last line is not terminated by a line break. If it is, then you can tweak the code to deal with that.
Alternatively, you can use Excel's built-in SUBSTITUTE function, which is useful in this particular case, because it can locate a specific instance of a given character. So instead of building arrays you can use a one-liner:
Function GetLastLines2(ByVal s As String, ByVal nLinesToDisplay As Long, _
Optional ByVal lineBreakChar As String = vbCrLf)
'An arbitrary character that will never be in your input string:
Dim delim As String: delim = Chr(1)
'How many lines are there?
Dim nLines As Long
nLines = UBound(Split(s, lineBreakChar)) + 1
If nLines <= nLinesToDisplay Then
'No need to remove anything. Get out.
GetLastLines2 = s
Exit Function
End If
'Replace one line break with delim, split the string on it,
'return only second part:
GetLastLines2 = Split( _
WorksheetFunction.Substitute( _
s, lineBreakChar, delim, nLines - nLinesToDisplay), _
delim)(1)
End Function
A = "Cat" & vbcrlf & "Tiger" & vbcrlf & "Lion" & vbcrlf & "Shark hunting florida lynxs" & vbcrlf & "Leopard" & vbcrlf & "Cheetah"
A= StrReverse(A)
NumLines = 3
i=1
For X = 1 to NumLines
i = Instr(i, A, vbcr) + 1
Next
Msgbox StrReverse(Left(A, i - 1))
This is a program that cuts or leaves lines from top or bottom of files.
To use
Cut
filter cut {t|b} {i|x} NumOfLines
Cuts the number of lines from the top or bottom of file.
t - top of the file
b - bottom of the file
i - include n lines
x - exclude n lines
Example
cscript //nologo filter.vbs cut t i 5 < "%systemroot%\win.ini"
The script
Set rs = CreateObject("ADODB.Recordset")
With rs
.Fields.Append "LineNumber", 4
.Fields.Append "Txt", 201, 5000
.Open
LineCount = 0
Do Until Inp.AtEndOfStream
LineCount = LineCount + 1
.AddNew
.Fields("LineNumber").value = LineCount
.Fields("Txt").value = Inp.readline
.UpDate
Loop
.Sort = "LineNumber ASC"
If LCase(Arg(1)) = "t" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber < " & LCase(Arg(3)) + 1
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber > " & LCase(Arg(3))
End If
ElseIf LCase(Arg(1)) = "b" then
If LCase(Arg(2)) = "i" then
.filter = "LineNumber > " & LineCount - LCase(Arg(3))
ElseIf LCase(Arg(2)) = "x" then
.filter = "LineNumber < " & LineCount - LCase(Arg(3)) + 1
End If
End If
Do While not .EOF
Outp.writeline .Fields("Txt").Value
.MoveNext
Loop
End With

Print dynamic list in pop up

I have a list of dynamic length from columns A to F. (starts at row 1) I need to make a code to have this list printed on a pop up. I don not want it printed on another sheet, the sheet this list is on is very hidden. I need to minimize copying these numbers thus why i don't want it on another sheet.
The proble is as i said this list is of dynamis length. So I'd have something like:
msgbox(upf.cells(1,1) & " " & upf.cells(1,2) & " " & upf.cells(1,3) & " " & upf.cells(1,4) _
upf.cells(2,1) & " " & upf.cells(2,2) & " " & upf.cells(2,3) & " " & upf.cells(2,4) _
... up to row lr)
How can I write this in some sort of a for i= 1 to lr loop?
Thank you!
As a basic example...
Sub tgr()
Dim upf As Range
Dim cIndex As Long
Dim rIndex As Long
Dim sMsg As String
Set upf = Range("A1", Cells(Rows.Count, "F").End(xlUp))
For rIndex = 1 To upf.Rows.Count
For cIndex = 1 To upf.Columns.Count
sMsg = sMsg & " " & upf.Cells(rIndex, cIndex)
Next cIndex
Next rIndex
MsgBox Mid(sMsg, 2)
End Sub