Bom dia,

Veja se o seguinte código atende:

Sub ReduzirColunas()
    Dim i As Long
    Dim j As Integer
    Dim k As Long
    Dim Produto As String
    Dim Loja As String
    Dim Linhas As Long
    Dim Colunas As Integer
    Dim Valor As Double
    Dim Dt As Date
    
    Linhas = [A1].CurrentRegion.Rows.Count
    Colunas = [A1].CurrentRegion.Columns.Count
    k = Linhas + 6
    Cells(k - 1, 1).Value = "Descrição do Produto"
    Cells(k - 1, 2).Value = "Nome da Loja"
    
    For j = 3 To Colunas
        Dt = Cells(1, j).Value
        For i = 2 To Linhas
            Produto = Cells(i, "A").Value
            Loja = Cells(i, "B").Value
            Valor = Cells(i, j).Value
            Cells(k, 1).Value = Produto
            Cells(k, 2).Value = Loja
            Cells(k, 3).Value = Dt
            Cells(k, 4).Value = Valor
            k = k + 1
        Next
    Next
End Sub

Abraço

José aparentemente deu certo. Fiz o teste na planilha teste, onde tem poucas linhas e poucas colunas e deu CERTO !!

Porem quando fui rodar na planilha original que tem 1.073 linhas e 92 colunas (uma combinação de 98.716 linhas) a macro ficou rodando por 1hora e daí eu interrompi e quando fui checar ela tinha "criado" mais de 18.200 linhas, talvez se rodasse por mais tempo teria dado tudo certo.

Será que tem como diminuir esse "time" ?

Enviando a planilha em anexo

Boa noite,

Tente esta nova versão do código:

Sub ReduzirColunas()
    Dim i As Long
    Dim j As Integer
    Dim k As Long
    Dim Produto As String
    Dim Loja As String
    Dim Linhas As Long
    Dim Colunas As Integer
    Dim Valor As Double
    Dim Dt As Date
    Dim tIni As Date
    Dim tDur As Date
    Dim tFim As Date
    
    tIni = Now
    Application.ScreenUpdating = False
    
    Linhas = [A1].CurrentRegion.Rows.Count
    Colunas = [A1].CurrentRegion.Columns.Count
    k = Linhas + 6
    Cells(k - 1, 1).Value = "Descrição do Produto"
    Cells(k - 1, 2).Value = "Nome da Loja"
    
    For j = 3 To Colunas
        Dt = Cells(1, j).Value
        For i = 2 To Linhas
            Produto = Cells(i, "A").Value
            Loja = Cells(i, "B").Value
            Valor = Cells(i, j).Value
            Cells(k, 1).Value = Produto
            Cells(k, 2).Value = Loja
            Cells(k, 3).Value = Dt
            Cells(k, 4).Value = Valor
            k = k + 1
            If k Mod 1000 = 0 Then
                Application.StatusBar = k
                DoEvents
            End If
        Next
    Next
    Application.StatusBar = k
    Application.ScreenUpdating = True
    tFim = Now
    tDur = tFim - tIni
    MsgBox "Fim de Execução da Macro em " & tDur
    Application.StatusBar = False
End Sub

Na barra de status vai aparecer o número da linha que está sendo preenchida.
Aqui rodou em 17 segundos e gerou 96.480 linhas.

Abraço

Show José deu certíssimo e em apenas 16seg, fiz o check dos valores por dia e também bateu !!!

Muito obrigado.

Abraço,
Igor Diniz