Notas emitidas por Produto - sem repetir
Enviado: 16 Mar 2019 às 18:46
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.
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