Matriz em VBA

[Luizrcm]

Olá pessoal tudo bem?

Estou com um pequeno problema de resposta do programa que fiz em vba, pois dentro desse código tenho duas matrizes com um total de quase 2 milhões de registros, ou seja, uma está declarada assim

varredura(30000,30)

e a outra assim

dataprox(30000,30)

totalizando 1,8M de registros.

Estou utilizando o FOR para selecionar cada registro da matriz para gravar

(parte do código)

for linha = 2 to 30000

for coluna = 1 to 30

varredura(linha,coluna)

.

.

.

.

next coluna

next linha

bem o problema é que demora de mais para terminar a execução dessa instrução pois faço a varredura e tratativa desses valores dentro desses FORs, queria saber se tem outro jeito de otimizar esse meu código.

(Todo o códogo)

Sub Auto_Open()

Dim varredura(40001, 41) As Long

Dim linha As Integer

Dim coluna As Integer

Dim prazo As Integer

Dim dataprox(30001, 31) As String

Dim dataconvert As Date

Dim menordata As Date

Dim mudalinha As Integer

coluna = 1

linha = 2

prazo = 0

menordata = Worksheets("Plan1").Cells(1, 25).Value

For linha = 2 To 30000

For coluna = 1 To 30

varredura(linha, coluna) = Worksheets("Plan1").Cells(linha, coluna).Value

Select Case varredura(linha, coluna)

Case 7

prazo = 10

dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo

dataprox(linha, coluna) = CStr(dataconvert)

If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed

Else

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite

End If

Case 13

prazo = 15

dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo

dataprox(linha, coluna) = CStr(dataconvert)

If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed

Else

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite

End If

Case 14

prazo = 30

dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo

dataprox(linha, coluna) = CStr(dataconvert)

If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed

Else

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite

End If

Case 25

prazo = 60

dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo

dataprox(linha, coluna) = CStr(dataconvert)

If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed

Else

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite

End If

Case 30

prazo = 90

dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo

dataprox(linha, coluna) = CStr(dataconvert)

If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed

Else

Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite

End If

End Select

Worksheets("Plan1").Cells(linha, coluna + 23).Value = dataprox

Next coluna

Next linha

End Sub

obrigado

[jeffsilveira]

Experimente utilizar o código

Application.ScreenUpdating = False

no início da macro e

Application.ScreenUpdating = True

no final.

Isso vai agilizar bastante o processo.

Abraços.

Vai ficar assim:

Sub Auto_Open()

Dim varredura(40001, 41) As Long
Dim linha As Integer
Dim coluna As Integer
Dim prazo As Integer
Dim dataprox(30001, 31) As String
Dim dataconvert As Date
Dim menordata As Date
Dim mudalinha As Integer

Application.ScreenUpdating = False

coluna = 1
linha = 2
prazo = 0
menordata = Worksheets("Plan1").Cells(1, 25).Value

For linha = 2 To 30000

For coluna = 1 To 30

varredura(linha, coluna) = Worksheets("Plan1").Cells(linha, coluna).Value

Select Case varredura(linha, coluna)

Case 7
prazo = 10
dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo
dataprox(linha, coluna) = CStr(dataconvert)
If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed
Else
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite
End If

Case 13
prazo = 15
dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo
dataprox(linha, coluna) = CStr(dataconvert)
If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed
Else
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite
End If

Case 14
prazo = 30
dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo
dataprox(linha, coluna) = CStr(dataconvert)
If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed
Else
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite
End If

Case 25
prazo = 60
dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo
dataprox(linha, coluna) = CStr(dataconvert)
If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed
Else
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite
End If

Case 30
prazo = 90
dataconvert = Worksheets("Plan1").Cells(2, 23).Value + prazo
dataprox(linha, coluna) = CStr(dataconvert)
If dataprox(linha, coluna) < Worksheets("Plan1").Cells(1, 25).Value Then
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbRed
Else
Worksheets("Plan1").Cells(linha, coluna).Interior.Color = vbWhite
End If

End Select
Worksheets("Plan1").Cells(linha, coluna + 23).Value = dataprox

Next coluna
Next linha

Application.ScreenUpdating = True

End Sub

[Luizrcm]

Obrigado!

Ajudou bastente mesmo, deu uma otimizada sim no projeto, dei uma enchugada nele e com essa função ele demorou 2.45 minutos para terminar a execução

[jeffsilveira]

Que bom que ajudou.

O simples fato de 'congelar' a tela durante a execução da macro aumenta bastante a velocidade.

[Patropi]

Caso o autor do tópico necessite, o mesmo será reaberto, para isso deverá entrar em contato com a moderação solicitando o desbloqueio.