Проверьте значения в столбце (ах), если все они одинаковы

Question

В настоящее время я создаю проверку для столбца.

Цель: У меня есть столбец под названием валюта, который мне нужно проверить, все ли они одинаковы для каждого банка (столбец A).Если есть другая валюта, то это мне подскажет.

Дополнительная цель: Я также хотел бы включить в проверку значение в столбце E (Валюта (банковский сбор)), чтобы убедиться, что все валюты для этого банка совпадают.

Проблема: У меня уже есть рабочий код с использованием scripting.dictionary, однако у меня возникли некоторые проблемы при очистке словаря для первого цикла / валют для первого банка.Я пытался очистить словарь, прежде чем он перейдет в другой банк.Но это не работает.

Ниже приведен скриншот того, что я хотел бы проверить:

Ниже приведен текущий кодчто у меня есть:

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

Вывод:

Предыдущие значения все еще находятся в словаре (доллары США - 3 и AUD - 2)

Благодарим вас за то, что у вас есть другое предложение сделать проверку.

Answer 1

Возможно, вы забыли сбросить счетчик расхождений в валюте x.
Установите значение x = 0 после первого цикла банка.

т.е.

...
...

    '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

...
...

И, как сказал TinMan, также сбросьте msg, чтобы результаты предыдущего банка не попали в ваш следующий банк.