Private Sub Teste1()
Screen.MousePointer = 11
Dim sTeto As Currency
Dim sCompAtual As String
Dim sCpfAtual As String
Dim sCompAntigo As String
Dim sCpfAntigo As String
Dim sVrAntigo As Currency

sTeto = 2400

FecharRst
sSql = "SELECT * FROM tblDuplicatas"
rst.Open sSql, cnBd, adOpenKeyset, adLockOptimistic

rst.MoveMin
sCpfAntigo = rst!Cpf
sVrAntigo = rst!Total
Do While Not rst.EOF
    If sVrAntigo < sTeto Then
        rst!BaseInss = sVrAntigo
        sTeto = sTeto - sVrAntigo
        ElseIf (sVrAntigo + 0.01) > sTeto Then
            rst!BaseInss = sTeto
            sTeto = 0
    End If

rst.Update
rst.MoveNext

If Not rst.EOF And Not rst.BOF Then
    If sCpfAntigo <> rst!Cpf Then
        sCpfAntigo = rst!Cpf
        sVrAntigo = rst!Total
        sTeto = 2400
        'MsgBox "Não é o mesmo - " & sCpfAntigo
        Else
        sVrAntigo = rst!Total
            'MsgBox "É o mesmo - " & sCpfAntigo
    End If
End If
Loop
FecharRst
Screen.MousePointer = 0
MsgBox "Atualização efetuada com sucesso ", vbExclamation, "Apuração da Base de Cálculo!!"
Exit Sub
End Sub

 

ESTOU USANDO O CÓDIGO ACIMA PARA ATUALIZAR UMA TABELA COM CERCA DE 110.000 REGISTROS. O PROBLEMA É QUE O PROCESSO DE ATUALIZAÇÃO ESTÁ LEVANDO MAIS DE 4 HORAS PARA SER PROCESSADO. ISSO É NORMAL, OU EXISTE UMA FORMA MAIS RÁPIDA DE ATUALIZAR OS REGISTROS? (SÃO APENAS 6 CAMPOS EM UMA TABELA QUE, SE QUER TEM RELACIONAMENTOS COM OUTRAS)..

 

ESTOU USANDO ADO

BDACCESS2000

Uma boa seria colocar índices nessa tabela. Porém, eu acho que esse procedure todo pode ser resumido em uma query só, com o mesmo resultado.

Marcone, a demora e na linha

sSql = "SELECT * FROM tblDuplicatas"
rst.Open sSql, cnBd, adOpenKeyset, adLockOptimistic

ou no loop ?

Coloque pontos de paradas para verificar.

 

Voce pode usar UPDATE com SELECT para tentar melhorar. Ou seja fazer um comando SQL que faca a atualizacao sem linhas de codigos. Assim

 

    arq.Execute "Insert Into cliente_temp " & _
        " Select * From cliente where status = 1" , dbSQLPassThrough

Neste caso simples coloca em cliente_temp todos os registros dos clientes com status = 1. Isso melhora bastante mais tem que ver se da para fazer a sua logica no comando sql pois a coisa nao é facil.

Eu quebrei a cabeça para chegar nessa lógica; mudá-la para uma mais simples, acho que vai ser mais difícil ainda.

 

De qualquer forma, obrigado pelas dicas!!

tenta assim:

Private Sub Teste1()
  Screen.MousePointer = 11
  Dim sTeto As Currency
  Dim sCompAtual As String
  Dim sCpfAtual As String
  Dim sCompAntigo As String
  Dim sCpfAntigo As String
  Dim sVrAntigo As Currency
  sTeto = 2400 
  sSql = "SELECT Cpf, Total, BaseInss FROM tblDuplicatas Order By Cpf"
  rst.Open sSql, cnBd, adOpenKeyset, adLockOptimistic
  rst.MoveMin
  sCpfAntigo = rst!Cpf
  sVrAntigo = rst!Total
  Do While Not rst.EOF
    If sVrAntigo < sTeto Then
      rst!BaseInss = sVrAntigo
      sTeto = sTeto - sVrAntigo
    ElseIf (sVrAntigo + 0.01) > sTeto Then
      rst!BaseInss = sTeto
      sTeto = 0
    End If
    rst.Update
    rst.MoveNext
    If Not rst.EOF And Not rst.BOF Then
      If sCpfAntigo <> rst!Cpf Then
        sCpfAntigo = rst!Cpf
        sVrAntigo = rst!Total
        sTeto = 2400
      Else
        sVrAntigo = rst!Total
      End If
    End If
  Loop
  FecharRst
  Screen.MousePointer = 0
  MsgBox "Atualização efetuada com sucesso ", vbExclamation, "Apuração da Base de Cálculo!!"
End Sub

***********

eu acho que tem resulter com apenas um update, mas para isso eu precisaria saber exatamente o que você precisa calcular ...

exemplo:

Update tblDuplicatas Set BaseInss = Iif(Total < 2400, Total, BaseInss)

 

qual o banco de dados que você utiliza?

Eu preciso apropriar um valor máximo mensal em várias rubricas até chegar ao limite.

 

Estou usando ACCESS

ADO