Macro Excel atribuir código a intes duplicados

[Robson Cardoso]

Boa tarde galera,

Estou precisando de uma ajuda de vocês, tenho aqui no trabalho uma planilha de levantamento de materiais que é composta por código, descritivo, quantidade, preço, etc.Os materiais se repetem várias vezes e o que gostaria é o seguinte quando eu inserir um código na célula A10 por exemplo a macro procure na coluna C pelo descritivo da célula C10 e caso encontre por exemplo na C30 a célula A30 receba o mesmo código da célula A10,

 

Segue imagem e planilha planilha pra facilitar o entendimento..

 

Obrigado!!

SOE.xls

[albert silva]

Para melhor lhe ajudar...

 

Anexe a planilha....

[Robson Cardoso]

Olá Bom dia,

Eu tentei anexar a planilha mas o fórum me disse que não tenho permissão pra anexar este tipo de arquivo a planilha está em XLSM.

Edit:Consegui anexar.

[Patropi]

Bom dia Robson

 

Para anexar este tipo de arquivo você tem que compactar.

 

[]s

[Robson Cardoso]

Bom dia Patropi

Eu consegui anexar salvando em xls, mas obrigado pela dica.

[Patropi]

Robson

 

Se você tivesse em outra planilha, ou na parte não visível da mesma planilha, uma relação desse material com o código, dava para aplicar na coluna"A" as funções ÍNDICE/CORRESP para retornar esses códigos, sem necessidade de usar macros.

 

[]s

[Robson Cardoso]

Eu pensei nisso mas os códigos variam cada vez que fazemos uma planilha como essa, não são códigos fixos.

[Robson Cardoso]

Galera consegui chegar nesse código, 

    Sub Find_Matches()    Dim CompareRange As Variant, x As Variant, y As Variant, Z As Variant    Dim iRet As Integer    Dim strPrompt As String    Dim strTitle As String     ' Promt    strPrompt = "Deseja copiar os códigos existentes?"     ' Dialog's Title    strTitle = "Copiar códigos"     'Display MessageBox    iRet = MsgBox(strPrompt, vbYesNo, strTitle)     ' Check pressed button    If iRet = vbNo Then           Else         Application.ScreenUpdating = False          Set CompareRange = Range("C10", ActiveSheet.Range("C65536").End(xlUp))     CompareRange.Select             For Each x In Selection                    If x.Offset(0, -2).Value <> "" Then                    Z = x.Offset(0, -2).Value         For Each y In CompareRange             If x = y Then y.Offset(0, -2).Select             If ActiveCell = "" Then             ActiveCell.Value = Z             End If             Next y         Else         End If     Next x     End If    End Sub    

Mas por algum motivo o primeiro código que a macro encontra ela cola ná célua C10 alguém sabe o que está errado?

 

Valeu

[Visitante]

Experimente:

Sub ProcuraMaterial() Dim cód As Range, mat As Range, frstAddMat As String, LRa As Long, LRc As Long  LRa = Cells(Rows.Count, 1).End(xlUp).Row: LRc = Cells(Rows.Count, 3).End(xlUp).End(xlUp).Row  Set cód = Range("A22:A" & LRa).Find([A10], lookat:=xlWhole)    If Not cód Is Nothing Then      Set mat = Range("C22:C" & LRc).Find(cód.Offset(, 2).Value, lookat:=xlWhole)       If Not mat Is Nothing Then        frstAddMat = mat.Address        Do          Cells(mat.Row, 1) = [A10]           Set mat = Range("C22:C" & LRc).FindNext(mat)        Loop While Not mat Is Nothing And mat.Address <> frstAddMat       End If    Else: MsgBox "código não encontrado"    End IfEnd Sub

 

[Robson Cardoso]

@osvaldomp testei esse código e nada aconteceu.

 

 

 

 

Obrigado

[Visitante]

... testei esse código e nada aconteceu.

 

 

Coloque um código de produto em "A10" (conforme a sua descrição no post #1) e rode o código que postei.

 

Se não apresentar o resultado esperado sugiro que você disponibilize uma amostra do seu arquivo com o código instalado.

[Robson Cardoso]

Consegui galera, segue o código a quem precise de algo parecido;

   Sub Find_Matches()    Dim CompareRange As Variant, x As Variant, y As Variant, Z As Variant    Dim iRet As Integer    Dim strPrompt As String    Dim strTitle As String     ' Promt    strPrompt = "Deseja copiar os códigos existentes?"     ' Dialog's Title    strTitle = "Copiar códigos"     'Display MessageBox    iRet = MsgBox(strPrompt, vbYesNo, strTitle)     ' Check pressed button    If iRet = vbNo Then         Else         Application.ScreenUpdating = False          Set CompareRange = Range("C7", ActiveSheet.Range("C65536").End(xlUp))     CompareRange.Select             For Each x In Selection                    If x.Offset(0, -2).Value <> "" Then                    Z = x.Offset(0, -2).Value         For Each y In CompareRange             If x = y Then y.Offset(0, -2).Select             If ActiveCell = "" Then             ActiveCell.Value = Z             End If             Next y         Else         End If     Next x     End If    End Sub

Caso alguém tenha alguma sugestão podem falar