Ajuda com macro

[fabioceolin]

Boa Noite!

Pessoal eu tenho esse macro rodando mas ele demora muito pois ele apaga todos valores pra preencher de novo, queria que ele adiciona-se os valores a partir da celula em que esta em branco mas não estou conseguindo fazer, teria como dar uma ajuda?

 

segue o codigo:

Sub OQU_Periodo()

 

    Dim Row, Col, RowR, ColR, Lim As Integer

    Dim Soma As Double

    

    'Macro Totaliza OQU reprocessado por período conforme frequencia de análise estabelecida

    

    'MA-1

    

    Row = 6

    RowR = 6

    Sum = 0

    Lim = 6

    

    Range("G6").Select

    Selection.End(xlDown).Select

    Lim = ActiveCell.Row

    

    

    Range("A6:I1000").Select

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Add Key:=Range( _

        "G6:G1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets("Reprocesso").Sort

        .SetRange Range("A5:I1000")

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    

    Range("L6:L1000").Select

    Selection.ClearContents

    Range("L6").Select

    

    Do While Range(Cells(Row, 11), Cells(Row, 11)).Value < Range("G1").Value

      If RowR <= Lim Then

    

        If Range(Cells(RowR, 7), Cells(RowR, 7)).Value < Range(Cells(Row, 11), Cells(Row, 11)).Value Then

            Sum = Sum + Range(Cells(RowR, 5), Cells(RowR, 5))

            RowR = RowR + 1

        Else

            Range(Cells(Row, 12), Cells(Row, 12)).Value = Sum

            Sum = 0

            Row = Row + 1

        End If

      Else

      Range(Cells(Row, 12), Cells(Row, 12)).Value = Sum

      Sum = 0

      Row = Row + 1

      End If

    Loop

 

 

    'MA-2

    

    Row = 6

    RowR = 6

    Sum = 0

    Lim = 6

    

    Range("T6").Select

    Selection.End(xlDown).Select

    Lim = ActiveCell.Row

    

    

    Range("N6:V1000").Select

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Add Key:=Range( _

        "T6:T1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets("Reprocesso").Sort

        .SetRange Range("N5:V1000")

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    

    Range("Y6:Y1000").Select

    Selection.ClearContents

    Range("Y6").Select

    

    Do While Range(Cells(Row, 24), Cells(Row, 24)).Value < Range("G1").Value

      If RowR <= Lim Then

    

        If Range(Cells(RowR, 20), Cells(RowR, 20)).Value < Range(Cells(Row, 24), Cells(Row, 24)).Value Then

            Sum = Sum + Range(Cells(RowR, 18), Cells(RowR, 18))

            RowR = RowR + 1

        Else

            Range(Cells(Row, 25), Cells(Row, 25)).Value = Sum

            Sum = 0

            Row = Row + 1

        End If

      Else

      Range(Cells(Row, 25), Cells(Row, 25)).Value = Sum

      Sum = 0

      Row = Row + 1

      End If

    Loop

 

 

    'MA-3

    

    Row = 6

    RowR = 6

    Sum = 0

    Lim = 6

    

    Range("AG6").Select

    Selection.End(xlDown).Select

    Lim = ActiveCell.Row

    

    

    Range("AA6:AI1000").Select

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Reprocesso").Sort.SortFields.Add Key:=Range( _

        "AG6:AG1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets("Reprocesso").Sort

        .SetRange Range("AA5:AI1000")

        .Header = xlYes

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    

    Range("AL6:AL1000").Select

    Selection.ClearContents

    Range("AL6").Select

    

    Do While Range(Cells(Row, 37), Cells(Row, 37)).Value < Range("G1").Value

      If RowR <= Lim Then

    

        If Range(Cells(RowR, 33), Cells(RowR, 33)).Value < Range(Cells(Row, 37), Cells(Row, 37)).Value Then

            Sum = Sum + Range(Cells(RowR, 31), Cells(RowR, 31))

            RowR = RowR + 1

        Else

            Range(Cells(Row, 38), Cells(Row, 38)).Value = Sum

            Sum = 0

            Row = Row + 1

        End If

      Else

      Range(Cells(Row, 38), Cells(Row, 38)).Value = Sum

      Sum = 0

      Row = Row + 1

      End If

    Loop

 

 

End Sub

 

[CasaDoHardware]

Como o codigo é muito grande sugiro que disponibilize o arquivo para testes  Assim fica mais fácil identificar o problema.

[fabioceolin]

Na parte de reprocessos da planilha tem uma macro chamado "OQU_Periodo", ele verifica o conteúdo das células do lado e faz umas contas mas ele apaga tudo o que esta calculado e calcula novamente eu gostaria de alterar para que ele começa-se a fazer as contas a partir da célula que esta em branco pois ele faz isso em tres planilhas o que acaba levando muito tempo para fazer.

 

https://www.sendspace.com/file/fq7u72