Guru do Excel e Power BI

Olá, tenho um programa que venho trabalhando há tempo, que realiza exportação e importação de dados entre o arquivo do cliente e uma Database (.xls) no servidor.
A exportação é extremamente rápida, pois jogo somente os valores que foram alterados em uma variável, e através dela copio para base de dados.

Considerando que os valores a serem copiados são: Valor, Cor da fonte, Cor de fundo, Tamanho da Fonte,
na parte de importação uso esse código atualmente:

Código: Selecionar todos

Dim wbDatabase As Workbook
Dim sDatabase As Worksheet
Dim wbAtual As Workbook
Dim sAtual As Worksheet

Set wbDatabase = Application.Workbooks.Open("C:/database.xlsm")         'Database
Set wbAtual = ThisWorkbook                                              'Arquivo atual
Set sAtual = wbAtual.Worksheets(p)                                      'Planilha atual
Set sDatabase = wbDatabase.Worksheets(p)                                'Planilha database

For i = 8 To sAtual.Cells(sAtual.Cells.Rows.count, 1).End(xlUp).Row     'Linhas
    For j = 7 To 39                                                     'Colunas
        
        If sDatabase.Cells(i, j).Value <> sAtual.Cells(i, j).Value Then
            
            'Definir valores
            sAtual.Cells(i, j).Value = sDatabase.Cells(i, j).Value
            sAtual.Cells(i, j).Interior.Color = sDatabase.Cells(i, j).Interior.Color
            sAtual.Cells(i, j).Font.Color = sDatabase.Cells(i, j).Font.Color
            sAtual.Cells(i, j).Font.Size = sDatabase.Cells(i, j).Font.Size
        
        'Caso somente a cor de fundo seja diferente
        ElseIf sDatabase.Cells(i, j).Interior.Color <> sAtual.Cells(i, j).Interior.Color Then
            
            sAtual.Cells(i, j).Interior.Color = sDatabase.Cells(i, j).Interior.Color
            
        'Caso somente cor da letra diferente
        ElseIf sDatabase.Cells(i, j).Font.Color <> sAtual.Cells(i, j).Font.Color Then
            
            sAtual.Cells(i, j).Font.Color = sDatabase.Cells(i, j).Font.Color
        
        End If
    Next
Next

Ele está lento, mesmo tentando aplicar um filtro pra ele não copiar as células em branco...
A planilha tem 2 mil linhas aproximadamente, com 39 colunas...
Ja tentei gravar em uma matriz pra então sim comparar os valores, mas ai não consigo comprar dados como "cor de fundo" por ex.

Alguma ideia?

Veja se ajuda

Código: Selecionar todos

Public Sub ImportarDados()
    Dim wbDatabase As Workbook
    Dim sDatabase As Worksheet
    Dim wbAtual As Workbook
    Dim sAtual As Worksheet
    Dim i As Long, j As Long
    Dim lngUltLin   As Long
    Dim vrtVal(), vrtValBase(), vrtValFinal()
    Dim vrtCorFundo(), vrtCorFundoBase()
    Dim vrtCorFonte(), vrtCorFonteBase()
    Dim vrtTamanhoFonteBase()
    
    Set wbDatabase = Application.Workbooks.Open("C:\database.xlsm")         'Database
    Set wbAtual = ThisWorkbook                                              'Arquivo atual
    Set sAtual = wbAtual.Worksheets(1)                                      'Planilha atual
    Set sDatabase = wbDatabase.Worksheets(1)                                'Planilha database
    
    lngUltLin = sAtual.Cells(sAtual.Cells.Rows.Count, 1).End(xlUp).Row
    
    ReDim vrtVal(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtValBase(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtValFinal(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtCorFundo(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtCorFundoBase(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtCorFonte(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtCorFonteBase(1 To lngUltLin - 7, 1 To 33) As Variant
    ReDim vrtTamanhoFonteBase(1 To lngUltLin - 7, 1 To 33) As Variant

    
    vrtVal = sAtual.Range("G8:AM" & lngUltLin)
    vrtValBase = sDatabase.Range("G8:AM" & lngUltLin)
    
    For i = 8 To lngUltLin     'Linhas
        For j = 7 To 39         'Colunas
            vrtCorFundo(i - 7, j - 6) = sAtual.Cells(i, j).Interior.Color
            vrtCorFundoBase(i - 7, j - 6) = sDatabase.Cells(i, j).Interior.Color
            vrtCorFonte(i - 7, j - 6) = sAtual.Cells(i, j).Font.Color
            vrtCorFonteBase(i - 7, j - 6) = sDatabase.Cells(i, j).Font.Color
            vrtTamanhoFonteBase(i - 7, j - 6) = sDatabase.Cells(i, j).Font.Size
        Next j
    Next i
    
    For i = LBound(vrtVal, 1) To UBound(vrtVal, 1)   'Linhas
        For j = LBound(vrtVal, 2) To UBound(vrtVal, 2)    'Colunas
        
            If vrtValBase(i, j) <> vrtVal(i, j) Then
                'Definir valores
                vrtVal(i, j) = vrtValBase(i, j)
                sAtual.Cells(i + 8, j + 6).Interior.Color = vrtCorFundoBase(i, j)
                sAtual.Cells(i + 8, j + 6).Font.Color = vrtCorFonteBase(i, j)
                sAtual.Cells(i + 8, j + 6).Font.Size = vrtTamanhoFonteBase(i, j)
           
            'Caso somente a cor de fundo seja diferente
            ElseIf vrtCorFundoBase(i, j) <> vrtCorFundo(i, j) Then
                vrtValFinal(i, j) = vrtVal(i, j)
                sAtual.Cells(i + 8, j + 6).Interior.Color = vrtCorFundoBase(i, j)
               
            'Caso somente cor da letra diferente
            ElseIf vrtCorFonteBase(i, j) <> vrtCorFonte(i, j) Then
                vrtCorFonte(i, j) = vrtVal(i, j)
                sAtual.Cells(i + 8, j + 6).Font.Color = vrtCorFonteBase(i, j)
            End If
        Next
    Next
    
    sAtual.Range("G8:AM" & lngUltLin).Value = vrtVal
    
End Sub

Olá, não tinha pensado nesse método, com mais matrizes. O código ficou consideravelmente mais rápido (quase o dobro mais rápido),
porém continua "devagar", mas a grande diferença é que ele demora o mesmo independente de quantos registros tem pra alterar, o que é ótimo já.

Obrigado!

Guru do Excel e Power BI

Rotina de cópia muito lenta

Rotina de cópia muito lenta

Re: Rotina de cópia muito lenta

Rotina de cópia muito lenta