检查列中的值(如果所有值相同)

下面是我的当前代码:

子货币测试检查()

dim wkssource as worksheet:设置wkssource=thisworkbook.sheets(“test1”)

像我一样昏暗
模糊X长
将最后一行变暗为长
将strbankname变暗为字符串

设置d=createObject(“scripting.dictionary”)。

application.screenupdating=假

lastrow=wkssource.cells(wkssource.rows.count,“c”).end(xlup).row

对于i=2至最后一行

如果len(wkssource.cells(i,1).value)>0,则'if a new bank starts

如果len(strbankname)>0,则

对于每个K in d.键

斯特拉克
countcurrency=d(k)

msg=msg&strcheck&“-”&countcurrency&vbnewline
x= x+1

下一K

如果X>1,则

msgbox“银行有不同的货币”strbankname&vbnewline&_
vbnewline&msg,vbcritical,“警告”

否则

msgbox“货币对于”&strBankName、vbInformation、“相同货币”都是相同的”

结束如果

D.ReaveWALL

结束如果


strbankname=wkssource.cells(i,1).value

结束条件

'每个银行的货币

tmp=trim(wkssource.cells(i,3).value)
如果len(tmp)>0,则d(tmp)=d(tmp)+1

下一个

如果len(strbankname)>0,则

对于每个K in d.键

斯特拉克
countcurrency=d(k)

msg=msg&strcheck&“-”&countcurrency&vbnewline
x= x+1

下一K

如果X>1,则

msgbox“银行有不同的货币”strbankname&vbnewline&_
vbnewline&msg,vbcritical,“警告”

否则

msgbox“货币对于”&strBankName、vbInformation、“相同货币”都是相同的”

结束如果

结束如果

application.screenupdating=真

结束子
< /代码> 

输出:






以前的值仍在字典中(美元-3和澳元-2)

如果您还有其他的建议来做检查,我将不胜感激。

附加目标:我还想在支票中加入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和澳元-2)

如果您还有其他建议,请予以感谢。