1
\$\begingroup\$

What I needed was: For each valid line on sheet Kardex, copy it to sheet Conciliação, then check every valid line on sheet Razão that matches that Kardex line and copy them too.

A valid line from Kardex is a line that contains a document number on column 5. A valid line on Razão is a line that contains a string of thex

Basically I have a list of information that I need to group and check for differences

@Kaz helped me a lot with a sample code, which I studied and modified, and now have a fast working code. I had another code that took around more than 60 minutes to run. It also worked, but it was too slow. Now it runs on less than 3 minutes with the same data and gives me the same results.

First, I have a Class module named AgrupaDoc, that is a variant of what I saw here:

Public Key As String
Public SaldoKardex As Double
Public SaldoRazao As Double
Public Function ValorKardex() As Double
    ValorKardex = SaldoKardex
End Function
Public Function ValorRazao() As Double
    ValorRazao = SaldoRazao
End Function
Public Sub SomaKardex(Valor As Double)
    SaldoKardex = SaldoKardex + Valor
End Sub
Public Sub SomaRazao(Valor As Double)
    SaldoRazao = SaldoRazao + Valor
End Sub
Private Sub Class_Initialize()
    SaldoKardex = 0
    SaldoRazao = 0
End Sub

The objective of this Class Module is to store, for each document, its totals. Since it has a total for Kardex and a total for Razão, I could also use two dictionaries. But this allows me to group everything, making easier to call later.

Then I have my "Slow mode" code.

Sub slowmode(mode As Boolean)
If mode = True Then
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Else
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
End If
End Sub

Basically a code to enable and disable things from excel. If slow mode is on, it enables. If its false, disables.

Then I have a cleanup code. It runs after the slowmode (false)

Sub limpaconciliacaoanterior()
Dim r As Worksheet
Set r = Sheets("Razão")
Dim k As Worksheet
Set k = Sheets("Kardex")
Dim c As Worksheet
Set c = Sheets("Conciliação")
If r.AutoFilterMode Then r.Cells.AutoFilter
If c.AutoFilterMode Then k.Cells.AutoFilter
If k.AutoFilterMode Then c.Cells.AutoFilter
lrr = r.Cells(Rows.Count, 16).End(xlUp).Row
lrk = k.Cells(Rows.Count, 15).End(xlUp).Row
lrc = c.Cells(Rows.Count, 1).End(xlUp).Row + 1
If lrr > 1 Then
    Range(r.Cells(2, 16), r.Cells(lrr, 16)).ClearContents
End If
If lrk > 1 Then
    Range(k.Cells(2, 15), k.Cells(lrk, 15)).ClearContents
End If
If lrc > 2 Then
    Range(c.Cells(3, 1), c.Cells(lrc, 10)).ClearContents
End If
End Sub

Sometimes when the code finishes executing, I identify a problem, fix it, and need to run the code again. This is a good way to clear everything I need cleaned. If you notice, I clear the column 16 from Kardex and the column 15 from Razão. That's because the code marks, on that columns, which lines were used. Its a good way to check if a valid line is being skipped.

I also got this code from here, to check if an item exists on a collection

Public Function Exists(coll As Collection, Key As String) As Boolean

    On Error GoTo EH

    coll.Item Key

    Exists = True
EH:
End Function

It uses the error handler to return if a key exists or not on a certain key inside a collection.

Then, it comes the main code

Public Sub conciliaestoquenovo()
    Dim tempoinicial As Date
    tempoinicial = Now
    Dim o As Worksheet
    Set o = Sheets("Operações")
    Dim lro As Long
    lro = o.Cells(Rows.Count, 1).End(xlUp).Row
    Dim opentrada As New Collection
    Dim opsaida As New Collection
    Dim i As Long
    For i = 2 To lro
        If o.Cells(i, 3).Value = "S" Then
            opsaida.Add opsaida.Count + 1, CStr(o.Cells(i, 1).Value)
        ElseIf o.Cells(i, 3).Value = "E" Then
            opentrada.Add opentrada.Count + 1, CStr(o.Cells(i, 1).Value)
        End If
    Next i
    Dim NumeroDocumento As String
    Dim col As Collection
    Dim InfoDoc As AgrupaDoc
    Dim ValorSaldo As Double
    Set col = New Collection

    Dim Kardex As Worksheet
    Set Kardex = ThisWorkbook.Worksheets("Kardex") '/ Or, look up how to use sheet codenames. They are highly recommended.

    Dim Conciliacao As Worksheet
    Set Conciliacao = ThisWorkbook.Worksheets("Conciliação")
    Dim ulc As Long

    Dim Documentos As Scripting.Dictionary '/ You may need to set a reference to "microsoft Scripting Runtime" in Tools -> References.
    Set Documentos = New Dictionary

    Dim IntervaloKardex As Range '/ Where we'll get our thing data and put it in an array
    Dim CelulaSuperiorEsquerda As Range
    Dim UltimaLinha As Long
    With Kardex
        Set CelulaSuperiorEsquerda = .Cells(1, 1) '/ starting row +1 to avoid headers

        UltimaLinha = .Cells(.Rows.Count, 1).End(xlUp).Row

        Set IntervaloKardex = .Range(CelulaSuperiorEsquerda, .Cells(UltimaLinha, 14))
    End With

    Dim DocumentosArray As Variant
    DocumentosArray = IntervaloKardex.Value '/ our data is now in an N * 1 array

    Dim LB1 As Long '/ Lower bound of the first dimension of the array
    Dim UB1 As Long '/ Upper bound of the first dimension of the array
    LB1 = LBound(DocumentosArray, 1)
    UB1 = UBound(DocumentosArray, 1)
    ulc = Conciliacao.Cells(Rows.Count, 1).End(xlUp).Row
    Dim ix '/ our array index counter
    For ix = LB1 To UB1
        If Now - tempoinicial >= TimeValue("0:00:04") Then
            DoEvents
            tempoinicial = Now
            Application.StatusBar = "Agrupando documentos: " & Format(ix / UB1, "0.00%")
        End If
        NumeroDocumento = CStr(DocumentosArray(ix, 5))
        If NumeroDocumento <> vbNullString And NumeroDocumento <> "Docto" Then
            If Mid(NumeroDocumento, 1, 3) = "REQ" Then
                NumeroDocumento = Mid(NumeroDocumento, 5, 10)
            ElseIf Mid(NumeroDocumento, 1, 3) = "NFE" Or Mid(NumeroDocumento, 1, 3) = "NFS" Then
                NumeroDocumento = Mid(NumeroDocumento, 5, InStr(1, NumeroDocumento, "-") - 5)
            End If
            Documentos.Item(NumeroDocumento) = NumeroDocumento
            ulc = ulc + 1
            ValorSaldo = CDbl(DocumentosArray(ix, 11))
            Conciliacao.Cells(ulc, 1).Value = "Kardex"
            Conciliacao.Cells(ulc, 2).Value = CDate(DocumentosArray(ix, 1))
            Conciliacao.Cells(ulc, 3).Value = NumeroDocumento
            Conciliacao.Cells(ulc, 4).Value = CStr(DocumentosArray(ix, 3))
            If Exists(opsaida, CStr(DocumentosArray(ix, 3))) = True Then
                Conciliacao.Cells(ulc, 5).Value = 0
                Conciliacao.Cells(ulc, 6).Value = ValorSaldo
                ValorSaldo = ValorSaldo * -1
            ElseIf Exists(opentrada, CStr(DocumentosArray(ix, 3))) = True Then
                Conciliacao.Cells(ulc, 5).Value = ValorSaldo
                Conciliacao.Cells(ulc, 6).Value = 0
            End If
            Conciliacao.Cells(ulc, 7).Value = CStr(DocumentosArray(ix, 4))
            Kardex.Cells(ix, 15).Value = "x"
            'Começa Classe
                Set InfoDoc = Nothing: On Error Resume Next
                Set InfoDoc = col(NumeroDocumento): On Error GoTo 0
                If InfoDoc Is Nothing Then
                    Set InfoDoc = New AgrupaDoc
                    InfoDoc.Key = NumeroDocumento
                    col.Add InfoDoc, NumeroDocumento
                End If
                'Add cell values to the class object
                With InfoDoc
                    .SomaKardex ValorSaldo
                End With
            'Termina Classe
        End If
    Next ix
    '/ Now, our Documentos will contain only unique thing names

    Dim Razao As Worksheet
    Set Razao = ThisWorkbook.Worksheets("Razão")
    Dim IntervaloRazao As Range
    With Razao
        Set CelulaSuperiorEsquerda = .Cells(1, 1) '/ starting row +2 to avoid headers

        UltimaLinha = .Cells(.Rows.Count, 15).End(xlUp).Row

        Set IntervaloRazao = .Range(CelulaSuperiorEsquerda, .Cells(UltimaLinha, 15))
    End With

    Dim HistoricosArray As Variant
    HistoricosArray = IntervaloRazao.Value

    LB1 = LBound(HistoricosArray, 1)
    UB1 = UBound(HistoricosArray, 1)

    Dim keytest As Variant
    Dim TextoHistorico As String
    Dim progresso As Long
    progresso = 0
    For Each keytest In Documentos.Keys()
        progresso = progresso + 1
        If Now - tempoinicial >= TimeValue("0:00:04") Then
            DoEvents
            tempoinicial = Now
            Application.StatusBar = "Procurando documentos na Contabilidade: " & Format(progresso / Documentos.Count, "0.00%")
        End If
        NumeroDocumento = CStr(keytest)
        For ix = LB1 To UB1
            TextoHistorico = CStr(HistoricosArray(ix, 8))
            If InStr(TextoHistorico, NumeroDocumento) > 0 Then
                ulc = ulc + 1
                ValorSaldo = CDbl(HistoricosArray(ix, 12)) - CDbl(HistoricosArray(ix, 13))
                Conciliacao.Cells(ulc, 1).Value = "Razão"
                Conciliacao.Cells(ulc, 2).Value = CDate(HistoricosArray(ix, 1))
                Conciliacao.Cells(ulc, 3).Value = NumeroDocumento
                Conciliacao.Cells(ulc, 4).Value = CStr(HistoricosArray(ix, 3))
                Conciliacao.Cells(ulc, 5).Value = CDbl(HistoricosArray(ix, 12))
                Conciliacao.Cells(ulc, 6).Value = CDbl(HistoricosArray(ix, 13))
                Conciliacao.Cells(ulc, 7).Value = CStr(HistoricosArray(ix, 8))
                Razao.Cells(ix, 16).Value = "x"
                'Começa Classe
                Set InfoDoc = Nothing: On Error Resume Next
                Set InfoDoc = col(NumeroDocumento): On Error GoTo 0
                If InfoDoc Is Nothing Then
                    Set InfoDoc = New AgrupaDoc
                    InfoDoc.Key = NumeroDocumento
                    col.Add InfoDoc, NumeroDocumento
                End If
                'Add cell values to the class object
                With InfoDoc
                    .SomaRazao ValorSaldo
                End With
            'Termina Classe
            End If
        Next ix
    Next keytest
'Classifica / organiza
    Application.StatusBar = "Organizando documentos"
    Conciliacao.Sort.SortFields.Clear
    Conciliacao.Sort.SortFields.Add Key:=Range( _
        "C3:C" & ulc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    Conciliacao.Sort.SortFields.Add Key:=Range( _
        "A3:A" & ulc), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With Conciliacao.Sort
        .SetRange Range("A2:G" & ulc)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Dim continue As Boolean
    Dim doc As String
    continue = True
    i = 3
    Do While continue = True
    If Now - tempoinicial >= TimeValue("0:00:04") Then
        DoEvents
        tempoinicial = Now
        Application.StatusBar = "Agrupando e totalizando: " & Format(i / Conciliacao.Cells(Rows.Count, 1).End(xlUp).Row, "0.00%")
    End If
    i = i + 1
    If Conciliacao.Cells(i, 3).Value <> Conciliacao.Cells(i - 1, 3).Value And Conciliacao.Cells(i - 1, 3).Value <> vbNullString Then
        Rows(i).Insert
        i = i - 1
        doc = Conciliacao.Cells(i, 3).Value
        Set InfoDoc = col(doc)
        If InfoDoc.ValorRazao <> 0 Then
            i = i - 1
            Conciliacao.Cells(i, 8).Value = "Valor Kardex"
            Conciliacao.Cells(i, 9).Value = InfoDoc.ValorKardex
            i = i + 1
            Conciliacao.Cells(i, 8).Value = "Valor Razão"
            Conciliacao.Cells(i, 9).Value = InfoDoc.ValorRazao
            i = i + 1
            Conciliacao.Cells(i, 8).Value = "Diferença"
            Conciliacao.Cells(i, 9).Value = Round(InfoDoc.ValorKardex - InfoDoc.ValorRazao, 2)
            If Round(InfoDoc.ValorKardex - InfoDoc.ValorRazao, 2) <> 0 Then
                Conciliacao.Cells(i, 10).Value = "Analisar"
            End If
        Else
            Conciliacao.Cells(i, 8).Value = "Valor Kardex"
            Conciliacao.Cells(i, 9).Value = InfoDoc.ValorKardex
            i = i + 1
            Conciliacao.Cells(i, 8).Value = "Diferença"
            Conciliacao.Cells(i, 9).Value = Round(InfoDoc.ValorKardex - InfoDoc.ValorRazao, 2)
            If Round(InfoDoc.ValorKardex - InfoDoc.ValorRazao, 2) <> 0 Then
                Conciliacao.Cells(i, 10).Value = "Analisar"
            End If
        End If
        i = i + 1
        'continue = False
    End If
    If Conciliacao.Cells(i, 3).Value = vbNullString Then
        continue = False
    End If
    Loop
    Application.StatusBar = ""
End Sub

Basically, it groups the Operações into 2 collections (Because the sheet Kardex lacks this information), then it adds every document from a valid line of Kardex to a dictionary, copies them to Conciliação, add/subtracts for that document on the class module, and marks the line as used. Then, with this dictionary, it checks every valid line on Razão, checks if it contains the document, copies to Conciliação, add/subtracts for that document on the class module, and marks the line as used.

After all information is at the same place, it sorts by document/origin. Then it adds a line between the groups of documents, and grab the totals from the class module. If there is a difference between totals, it marks for me too look later.

After that, it turns slowmode (true)

To be honest, I am still kinda lost on how the class module works. The dictionaries and arrays sure do speed up the code. The next step is to probably sort the information on an array instead of putting it on Conciliação and do the sorting, but I still cant figure out how to sort values with 2 conditions in an array.

\$\endgroup\$
  • \$\begingroup\$ Just an aside, if you use a dictionary instead of a collection, they have an inbuilt .Exists method \$\endgroup\$ – Kaz Sep 28 '17 at 11:44
  • \$\begingroup\$ @Kaz Back to the drawing board then! There is always room for improvement \$\endgroup\$ – Moacir Sep 28 '17 at 11:47
  • \$\begingroup\$ If all sheets are in the same workbook, and if you like SQL, I would use SQL and an ADODB connection. See analystcave.com/excel-using-sql-in-vba-on-excel-data \$\endgroup\$ – Patrick Honorez Jul 3 '18 at 14:10
  • \$\begingroup\$ A SQL solution would be ideal, but it is beyond the tools I have access, due to security concerns. There is a ticket to make the system that generates the reports to also do this check, but it is not a priority right now, due other circumstances. \$\endgroup\$ – Moacir Jul 3 '18 at 14:15

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.