Este fórum está sendo desativado

[xmiguelx]

Boa noite!

Estou tentando adaptar o código VB para que não repita o número de nota para o mesmo produto.

Exemplo: O código de produto W0259171 está repetindo várias vezes á nota 000303651 e assim para outras notas sendo que gostaria que apareça somente uma vez essa nota para esse produto, e essa nota poderá aparecer em outros produtos.

Segue arquivo de exemplo o qual reproduzi manualmente na Sheet RESUMO, coluna U o objetivo que estou buscando que ocorra na Sheet RESUMO, coluna T quando é pressionado o botão RESUMO.

Abs

[FelipeMGarcia]

Amigo,

Veja se o que fiz lhe ajuda, caso queira agradecer, clique na mãozinha.

Abs

[xmiguelx]

Bom dia amigo!

Estou tentando fazer via VB, pois meu relatório de notas pode passar de 2000 notas a cada reanalise.

Abs

[FelipeMGarcia]

Se mudar de ideia, segue a fórmula:

=UNIRTEXTO(" , ";VERDADEIRO;MENOR(SE(FREQÜÊNCIA(SE(NOTAS!$B$3:$B$74=$B3;CORRESP(NOTAS!$D$3:$D$74;NOTAS!$D$3:$D$74;0));LIN(NOTAS!$D$3:$D$74)-LIN(NOTAS!$D$3)+1);NOTAS!$D$3:$D$74);LIN(INDIRETO("1:"&SOMA(SE(FREQÜÊNCIA(SE(NOTAS!$B$3:$B$74=$B3;CORRESP(NOTAS!$D$3:$D$74;NOTAS!$D$3:$D$74;0));LIN(NOTAS!$D$3:$D$74)-LIN(NOTAS!$D$3)+1);1))))))

[osvaldomp]

Estou tentando fazer via VB, ...

Pode ser via VBA ?

Código: Selecionar todos

Sub Resumo()
 Dim m As String, k As Long, x As Long
  Application.ScreenUpdating = False
  Sheets.Add
  Sheets("NOTAS").Range("B3:D" & Sheets("NOTAS").Cells(Rows.Count, 2).End(3).Row).Copy [A3]
  ActiveSheet.Range("A3:C" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
  With Sheets("RESUMO")
   .Columns(2) = "": .Columns(20) = "": .[B2] = "PRODUTO": .[T2] = "NOTAS"
   For k = 3 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
End Sub

[xmiguelx]

@ Felipe, muito obrigado pela sua ajuda, funcionou perfeitamente através de fórmula.

@Osvaldo, muito obrigado, realmente queria por VB devido a grande quantidade e assim minimizando o risco de deixar de colocar a fórmula em algum item.

Abs