How to print cell "values" in MsgBox? - excel

I have VBA code that goes to a reference workbook and makes a report based on sheet names needed.
After this is done I have a output into cells of all the sheets it couldnt find and I want to put it in a MsgBox that pops up with the list of worksheets not found.
Here is the output of those missing sheets:
On Error Resume Next
Do While y \<= x
Workbooks(maker).Activate
Z = Range("u10:u" & cnt).Find(what:=y, LookIn:=xlValues, lookat:=xlWhole).Select
If Err \> 0 Then
V = Range("E10:E" & cnt).Find(what:=y, LookIn:=xlValues, lookat:=xlWhole).Select
t = Selection.Offset(0, 1)
'This is where the not found worksheets are printed in column w
Range("w" & q).Value = t
q = q + 1
y = y + 1
Else
t = Selection.Offset(0, -1)
Workbooks(Filename).Sheets(t).Copy After:=Workbooks(temp).Sheets(Workbooks(temp).Sheets.Count)
Workbooks(maker).Activate
y = y + 1
End If
Loop
On Error GoTo 0
How would I go about making that Range("w" &q).Value=t into a message box that lists the worksheet names?
I have been scouring google looking for ideas or solutions but am having issues with formulating this solution. Any help or guidance is appreciated.

On Error Resume Next
sMsgTxt = "" ' Initialize msgbox string
Do While y <= x
Workbooks(maker).Activate
Z = Range("u10:u" & cnt).Find(what:=y, LookIn:=xlValues, lookat:=xlWhole).Select
If Err > 0 Then
V = Range("E10:E" & cnt).Find(what:=y, LookIn:=xlValues, lookat:=xlWhole).Select
t = Selection.Offset(0, 1)
'This is where the not found worksheets are printed in column w
Range("w" & q).Value = t
sMsgTxt = sMsgTxt & t & vbCrLf ' Append to msgbox string
q = q + 1
y = y + 1
Else
t = Selection.Offset(0, -1)
Workbooks(Filename).Sheets(t).Copy After:=Workbooks(temp).Sheets(Workbooks(temp).Sheets.Count)
Workbooks(maker).Activate
y = y + 1
End If
Loop
MsgBox sMsgTxt ' Output msgbox string
On Error GoTo 0

First, What line pops the error message?
Either way, this is a way to build a message from multiple lines. I realize you're finding sheets that don't exist, so the whole For Each WS thing doesn't apply... but it's useful to demonstrate.
Sub MessageFromCellValues()
Dim Msg As String
Dim maker As String
Dim WS As Worksheet
Dim X As Long
Dim Y As Long
maker = "Your Worksheet Name.xlsm"
'Do While Y <= X
' ... Your Code
'Loop
Msg = " This is the list of Sheet Names " & vbCrLf & vbCrLf
For Each WS In Workbooks(maker).Worksheets
Msg = Msg & " - " & WS.Name & vbCrLf
Next WS '
MsgBox Msg, vbOKOnly, "Sheets List"
End Sub
Example:

Related

Excel VBA: Data entry based on Listbox values, checks against existing entries

Can't find a way to tell my code that the entry has occurred for a certain user and no additional steps are required when the loop is complete. The issue that I have is that is harder to control or escape my loops so the first loop cannot be ended easily; I have tried giving a value to establish this but it will end it prematurely since there are times when you need to run it, perhaps a different approach can be utilized which I cannot figure out yet.
My current issue is that the code always adds a duplicate of the last user in the user box no matter what and that's because my last if statement checks out ok so it will add it anyway. I want to eliminate that if possible or have another approach.
Here is my code:
'############### START OF CODE SUBMISSION ###############
' define variables
Dim i As Integer, x As Integer, l As Integer, ws As Worksheet, lRow As Long, a As Integer, m As Integer, lCol As Integer, c As Integer, ct As Integer, isDone As Boolean
isDone = False
l = Me.lstDocs.ListCount ' count all entered documents
a = Me.lstTrainee.ListCount ' count all entered names
For x = 0 To l - 1 ' run through documents entered
For m = 0 To a - 1 ' run through names entered
' navigate throgh all entered documents
Set ws = Application.Worksheets(Me.lstDocs.List(x, 0))
' find last row of the selected document
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lCol = ws.Cells(2, Columns.Count).End(xlToLeft).Column
' find matching name, if nothing, add name to list of document matrix
For i = 2 To lRow
If Trim(ws.Cells(i, 1).Value) = Trim(Me.lstTrainee.List(m)) Then ' find the name from existing list on doc matrix
For c = 2 To lCol ' loop through revision until found
' check revision and dates
If Trim(Me.lstDocs.List(x, 1)) = Trim(ws.Cells(2, c).Value) Then ' revision found under the name
' perfect world
If Trim(ws.Cells(i, c).Value) = "" Then ' check that nothing is there under revision column
' MsgBox Me.lstDocs.List(x, 2) debugger to see if it is falling in.
ws.Cells(i, c).Value = Me.lstDocs.List(x, 2) ' add date to cell
With ws
.Hyperlinks.Add Anchor:=ws.Cells(i, c), _
Address:=Me.txtAddress.Value, _
ScreenTip:=Me.txtAddress.Value, _
TextToDisplay:="Open Training File"
End With
ct = ct + 1
If m < a - 1 Then
m = m + 1
' MsgBox "Hit uninteded staetment."
End If
isDone = True
' isDone = True ' commented out LAST ***
Exit For
Else
If MsgBox("Trainee: " & Me.lstTrainee.List(m) & " has been trained on " & ws.Cells(i, c).Value & " on Doc.: " & Me.lstDocs.List(x, 0) & " Rev.: " & Me.lstDocs.List(x, 1) & ". Would you like to replace this?", vbYesNo + vbQuestion) = vbYes Then
' ws.Cells(i, c).Value = Me.lstDocs.List(x, 2) ' replace current value
' ct = ct + 1
' Exit For
Else ' if no is clicked
If i = lRow Then ' last step
' enter the trainig at the end
ws.Cells(lRow + 1, 1).Value = Me.lstTrainee.List(m)
ws.Cells(lRow + 1, c).Value = Me.lstDocs.List(x, 2)
With ws
.Hyperlinks.Add Anchor:=ws.Cells(lRow + 1, c), _
Address:=Me.txtAddress.Value, _
ScreenTip:=Me.txtAddress.Value, _
TextToDisplay:="Open Training File"
End With
ct = ct + 1
' i = lRow
isDone = True
Exit For ' kick out of loop for c
End If
' MsgBox "No Changes were made for: " & Me.lstTrainee.List(m)
End If
End If
' Exit For
End If
' this is where the new can be added as needed
Next c
' Exit For ' kick out of first document revision and continue with next
End If
' If isDone = True Then Exit For
' if this is the last row, most likely the name has not been found. Proceed to add it to the list
If i = lRow And Trim(ws.Cells(lRow, 1).Value) <> Trim(Me.lstTrainee.List(m)) And isDone <> True Then ' always adds at the bottom if no data is captured.
For c = 2 To lCol
If Trim(Me.lstDocs.List(x, 1)) = Trim(ws.Cells(2, c).Value) Then ' revision found under the name
ws.Cells(i + 1, 1).Value = Me.lstTrainee.List(m)
ws.Cells(i + 1, c).Value = Me.lstDocs.List(x, 2)
With ws
.Hyperlinks.Add Anchor:=ws.Cells(i + 1, c), _
Address:=Me.txtAddress.Value, _
ScreenTip:=Me.txtAddress.Value, _
TextToDisplay:="Open File"
End With
ct = ct + 1
End If
Next c
End If
' If isDone = True Then Exit For
Next i
Next m
Next x
MsgBox "A total of " & ct & " records were added.", vbInformation
Call populatorWS
End Sub

VB script to identify missing mandatory cell values across different rows and columns in excel

I have an excel file contains 20 columns and 100 rows, If the Value in A2= Reportable certain columns in excel are mandatory and similarly if A2 =Non-Reportable then certain other column values are mandatory, So need an VB script to check this condition if any of the mandatory column cell value is blank then on save of excel file throw an error message and error message should list all the missing column headers and rows. The script should validate all the rows, tried the below code, but not working and also i get mutiple error message instead of single error message
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim Cell As Range
Dim flag As Boolean
flag = False
If Cells(1, 1) = "" Then flag = True
For Each Cell In Range("B2:B3")
If Cell = "" Then
MsgBox ("Signoff is missing")
flag = True
Exit For
End If
Next Cell
For Each Cell In Range("D2:D3")
If Cell = "" Then
MsgBox ("tax Regime value is missing")
flag = True
Exit For
End If
Next Cell
For Each Cell In Range("E2:E3")
If Cell = "" Then
MsgBox ("Classification value is missing")
flag = True
Exit For
End If
Next Cell
Cancel = flag
End Sub
update - added error.txt as output
update2 - colour cells red and create error sheet
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim ws As Worksheet, lastrow As Long, ar(2)
Dim msg As String, c As String
Dim r As Long, i As Long, n As Long
ar(1) = Array("B", "D", "F") ' non-reportable columns
ar(2) = Array("C", "E", "G") ' reportable columns
Set ws = ActiveSheet
With ws
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 2 To lastrow
.Rows(r).Cells.Interior.Pattern = xlNone
n = 0
If LCase(.Cells(r, "A")) = "non-reportable" Then
n = 1
ElseIf LCase(.Cells(r, "A")) = "reportable" Then
n = 2
End If
If n > 0 Then
For i = 0 To UBound(ar(n))
c = ar(n)(i)
If .Cells(r, c) = "" Then
.Cells(r, c).Interior.Color = RGB(255, 0, 0) ' red
msg = msg & vbLf & "Row " & r & " missing " & .Cells(1, c)
End If
Next
End If
Next
End With
Dim wsErr As Worksheet, arErr
If Len(msg) > 0 Then
' create error sheet
arErr = Split(msg, vbLf)
Set wsErr = Sheets.Add(after:=Sheets(Sheets.Count))
wsErr.Name = "Errors " & Format(Now(), "yyyy-mm-dd hhmmss")
wsErr.Cells(1, 1).Resize(UBound(arErr) + 1) = Application.Transpose(arErr)
Open "errors.txt" For Output As #1
Print #1, msg
Close #1
MsgBox "Missing data see error.txt", vbCritical
Cancel = True
Else
MsgBox "All good"
End If
End Sub

Excel VBA script not working when grouping multiple levels

I have an excel document that runs a VBA script that I use user forms to input data. The script works fine, except for the grouping. There are 2 groups. The first is at the Customer Name, which works fine. The second is at the Effort Name, which does not. It groups the effort, but when grouped it still displays the last row. The developer I hired to write the script said that this error appears to be a bug in Excel or for some reason by design when two groups have the same last row.
Does anyone have a solution?
Images show the macros script and grouping Image of marcos
Image of grouping
Below is the VBA script that was written for creating the effort via user form.
Private Sub ButtonAddEffort_Click()
Dim c As Object
Dim sht As Worksheet
Dim foundrow As Long
Dim blassign As Boolean
Dim x As Long
Dim rowstart As Long
Dim rowend As Long
Dim i As Long
Dim rowstarteffort As Long
If IsNull(Me.txtProjectNumberLocate) Or Me.txtProjectNumberLocate = "" Then
MsgBox "Please enter a project number."
Me.txtProjectNumberLocate.SetFocus
Exit Sub
End If
If IsNull(Me.txtEffortName) Or Me.txtEffortName = "" Then
MsgBox "Please enter an effort name."
Me.txtEffortName.SetFocus
Exit Sub
End If
If Not IsNull(Me.txtStartDate) And Me.txtStartDate <> "" Then
If Not IsDate(Me.txtStartDate) Then
MsgBox "Please enter a valid start date in 'mm/dd/yyyy' format."
Me.txtStartDate.SetFocus
Exit Sub
End If
End If
If Not IsNull(Me.txtFinishDate) And Me.txtFinishDate <> "" Then
If Not IsDate(Me.txtFinishDate) Then
MsgBox "Please enter a valid finish date in 'mm/dd/yyyy' format."
Me.txtFinishDate.SetFocus
Exit Sub
End If
End If
Set sht = Sheets("Sheet1")
Set c = sht.Range("F:F").Find(what:=Me.txtProjectNumberLocate, after:=sht.Cells(1, 6), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not c Is Nothing Then
foundrow = c.Row
rowstart = foundrow
rowstarteffort = foundrow
Else
foundrow = 0
End If
If foundrow = 0 Then
MsgBox "Could not find project # " & Me.txtProjectNumberLocate
Exit Sub
End If
''any efforts exist1
Set c = sht.Range("A:A").Find(what:="*", after:=sht.Cells(foundrow, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
foundrownext = c.Row
Else
foundrownext = 0
End If
If foundrownext > foundrow Then
foundrow = foundrownext - 1
End If
'check work order format
For x = 1 To 8
If Not IsNull(Me("txtworkorder" & x)) And Me("Txtworkorder" & x) <> "" Then
If Me("CheckBox" & x) = True Then
If Len(Me("txtWorkOrder" & x)) <> 8 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Me("txtWorkOrder" & x), "-") = 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If Mid(Me("txtworkorder" & x), 5, 1) <> "-" Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Left(Me("txtWorkOrder" & x), 4), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
If InStr(1, Right(Me("txtWorkOrder" & x), 3), "-") <> 0 Then
MsgBox "Work order numbers must be in 'xxxx-xxx' format."
Me("txtWorkOrder" & x).SetFocus
Exit Sub
End If
End If
End If
Next x
i = 0
If foundrownext > 1 Then
sht.Rows(rowstart + 1 & ":" & foundrownext - 1).Select
On Error Resume Next
Selection.Rows.Ungroup
On Error GoTo 0
End If
blassign = False
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
blassign = True
End If
Next x
If blassign = False Then
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
i = 1
Else
sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
sht.Range("B" & foundrow + 1) = Me.txtEffortName
sht.Range("B" & foundrow + 1).Font.Color = 13998939
sht.Range("B" & foundrow + 1).Font.Underline = True
sht.Range("I" & foundrow + 1) = Me.txtStartDate
sht.Range("J" & foundrow + 1) = Me.txtFinishDate
For x = 8 To 1 Step -1
If Me("CheckBox" & x) = True Then
sht.Range(foundrow + 2 & ":" & foundrow + 2).EntireRow.Insert shift:=xlDown
sht.Range("F" & foundrow + 2) = Me("txtWorkOrder" & x)
sht.Range("G" & foundrow + 2) = Me("cmbAssign" & x)
i = i + 1
End If
Next x
End If
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
''
MsgBox "Done!"
End Sub
Private Sub ButtonClose_Click()
Unload Me
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub ComboBox2_Change()
End Sub
Private Sub ComboBox3_Change()
End Sub
Private Sub ComboBox4_Change()
End Sub
Private Sub TextBox9_Change()
End Sub
Private Sub UserForm_Click()
End Sub
Outline (group) in Excel requires a summary row, that depending on the settings you have in your computer, should be placed below (default) or above each outline level.
Your situation
What's happening in your spreadsheet is that you currently have the default settings, i.e. summary row should be below the current outline level. And you're grouping the rows 9,10 and 13.
My guess here is that the developer tried to group effort 1 and effort 2 and it didn't work, because to group effort 2 without leaving an additional row would just look like this:
Note: See the 4 dots on the right of rows 13 to 16
The Excel solution
In this case, you need to toggle the settings so the summary rows are above the detail
How to adjust the settings
Outline settings:
Current configuration:
Adjusted configuration
This would allow to have the summary row above details like this:
And when collapsed:
The VBA solution
Now, about the VBA code you have, although it can certainly be improved, I understand it accomplishes your requirements.
I suggest to specially check these two blocks:
Block # 1:
''group new efforts
If foundrownext <= 1 Then
foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group
Block #2
''ungroup and group old project data
rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group
I'd suggest the developer to read this article on how and why to avoid select in Excel VBA.
Please let me know if the solution works and remember to mark the answer (tick the check mark at the left) if it does.

InStr in Array not populating value if found

I've written the below code to search for a value(Supplier Name) in sheet "Fusion" Column H in sheet "CX" column D. I'm also doing a check the other way around so if the same value(Supplier Name) in sheet CX is in sheet "Fusion". I'm not looking for an Exact match hence the use of Instr and doing the comparison both ways as i'm not sure how a user has entered the information in either sheet.
The data type in either cell should be text.
If a match is found then in the last column of sheet "CX" it should just populate either "Supplier Found" or "Supplier Not Found"
Currently it's not populating the last column with any data but the Macro isn't erroring at any point.
I've tried adding msgboxes and "Here" and "Here3" are being triggered but it doesn't seem to be hitting the section of code that is "Here2" so I think it's there that's causing the issue but not sure how to resolve it.
Screenshot of my Data is :CX Sheet
Fusion Sheet
Any help would be greatly appreciated.
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim strTemp as string
Dim strCheck as string
Dim i As Long, J As Long
Dim CXArr As Variant
Dim FusionArr As Variant
Dim match As Boolean
Dim CXRng As Range
Dim FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
Set CXRng = CX.Range("A2", CX.Cells(Rows.Count, "A").End(xlUp).Offset(0, 6))
Set FusionRng = Fusion.Range("A2", Fusion.Cells(Rows.Count, "A").End(xlUp).Offset(0, 9))
CXArr = CXRng.Value2
FusionArr = FusionRng.Value2
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
For i = 1 To UBound(CXArr)
Match = False
For J = 1 To UBound(FusionArr)
MsgBox "Here"
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
MsgBox"Here2"
CXArr(i, 6) = "Supplier Found"
Else
Msgbox"Here3"
CXArr(i, 6) = "Supplier not found"
End If
Next J
Next i
End Sub
The expected output i'd expect is: If in Column H of Fusion the Supplier Name is "Supplier A" and the value in Column D of sheet "CX" is "Supplier A LTD" then i'd expect it to populate column G in sheet CX with "Supplier Found" due to it being found in the string.
If you need any more info please let me know.
I don't know how to correctly insert examples of my data else I would have
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim i As Long, J As Long, lastRowCX As Long, lastRowFU As Long
Dim CXText As String, FusionText As String
Dim match As Boolean
Dim CXRng As Range, FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
lastRowCX = CX.Range("D1").SpecialCells(xlCellTypeLastCell).Row - 1
lastRowFU = Fusion.Range("H1").SpecialCells(xlCellTypeLastCell).Row - 1
Set CXRng = CX.Range("D1:D" & lastRowCX)
Set FusionRng = Fusion.Range("H1:H" & lastRowFU)
For i = 1 To lastRowCX
match = False
For J = 1 To lastRowFU
'Debug.Print "Here"
FusionText = FusionRng.Range("A1").Offset(J, 0).Value
CXText = CXRng.Range("A1").Offset(i, 0).Value
If FusionText <> "" And CXText <> "" Then
If InStr(FusionText, CXText) Or InStr(CXText, FusionText) Then
'Debug.Print "Here2"
match = True
End If
End If
Next J
'Result goes to column G of CX range:
If match Then
CXRng.Range("A1").Offset(i, 3).Value = "Supplier found" ' "Supplier found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
Else
CXRng.Range("A1").Offset(i, 3).Value = "Supplier NOT found" '"Supplier NOT found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
End If
Next i
End Sub
You need to make sure to check for case sensitivity:
Dim strTemp as string
Dim strCheck as string
'Inside for I loop
'Inside for j Loop
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
'...
End If
'end for j
'end for i

Check values in column(s) if all are the same

Currently I'm creating a check for a column.
Goal: I have a column called currency which I need to check if they are all the same for each Bank (Column A). If there are other currency then it will prompt me.
Additional goal: I would also like to include in the checking the one in column E (Currency (Bank Charge)) to make sure that all currencies for that bank are the same.
Problem: I already have a working code using scripting.dictionary, however, I have some trouble clearing the dictionary for the first loop / currencies for the first Bank. I tried to clear the dictionary before it proceeds to another bank. But it is not working.
Below is the screenshot of what I would like to check:
Below is the current code that I have:
Sub CurrencyTestCheck()
Dim wksSource As Worksheet: Set wksSource = ThisWorkbook.Sheets("Test1")
Dim i As Long
Dim x As Long
Dim lastRow As Long
Dim strBankName As String
Set d = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
lastRow = wksSource.Cells(wksSource.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRow
If Len(wksSource.Cells(i, 1).Value) > 0 Then 'If a new bank starts
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
d.RemoveAll
End If
strBankName = wksSource.Cells(i, 1).Value
End If
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
End If
Application.ScreenUpdating = True
End Sub
Output:
Previous values are still in the dictionary (USD - 3 and AUD - 2)
Appreciate if you also have another suggestion to do the checking.
You might have forgotten to reset your currency discrepancy counter x.
Set it to x = 0 after the first bank's loop.
i.e.
...
...
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
' Add these two lines:
x = 0
msg = ""
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
...
...
And like TinMan said, also reset the msg so the previous bank's results don't leak into your the next bank.

Resources