Este fórum está sendo desativado

[xmiguelx]

Olá pessoal,

Preciso de uma mega ajuda, vou explicar a sistemática para que vocês consiga entender.

- Tenho uma planilha com uma Sheet com o nome de Base, nessa sheet eu coloco o relatório de todas as notas fiscais emitidas.
- Quando executo o Macro Preencher, na Sheet Resumo, coluna B eu coloco todos os códigos dos produtos referente a base sem que tenha repetição e na colunas T eu informo todos os números de notas correspondente ao produto, sem repetição, pois tem vezes que na mesma nota fiscal se repete o mesmo produto.

Porém está ocorrendo algum problema, pois não está trazendo todos os produtos para sheet resumo.

Não sei onde está o problema, pois fiz um teste alterando na sheet Base o número de todas ás notas, coluna D para AAA e o comando preencher funcionou perfeitamente, repetindo o número de nota para todos os registro, funcionou perfeitamente, porém numerando sequencialmente do 1 em diante para cada registro já não funciona.

Código: Selecionar todos

Sub Preencher()
    Dim x1, x2, x3, i As Long
    
    
'Summary NFe or NFSe

    Dim m As String, k As Long, x As Long
    Application.ScreenUpdating = False
    Sheets.Add
    Sheets("Base").Range("B3:D" & Sheets("Base").Cells(Rows.Count, 2).End(3).Row).Copy [A5]
    ActiveSheet.Range("A5:C" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
    With Sheets("RESUMO")
        .Columns(2) = "": .Columns(20) = "": .[B4] = "PRODUTO": .[T4] = "NOTAS Á COMPLEMENTAR"
        For k = 5 To Cells(Rows.Count, 1).End(3).Row
            x = Application.CountIf([A:A], Cells(k, 1))
            If x = 1 Then
                m = Cells(k, 3).Text
                Else: m = Join(Application.Transpose(Cells(k, 3).Resize(x)), " ; ")
            End If
            .Cells(Rows.Count, 2).End(3)(2) = Cells(k, 1)
            .Cells(Rows.Count, 20).End(3)(2).NumberFormat = "@": .Cells(Rows.Count, 20).End(3)(2) = m
            k = k + x - 1
            Next k
        End With
        Application.DisplayAlerts = False
        ActiveSheet.Delete
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True

    
'Quebrar texto

        Columns("T:T").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

[xmiguelx]

Olá Pessoal!

Caso tenham algum outro código que funcione, ficarei grato.

Abs