Página 1 de 1

Erro em macro para pesquisar conteúdo e escrever mensagem

Enviado: 30 Mai 2019 às 00:18
por duucerqueira
Olá, pessoal!

Estou precisando de ajuda com uma pequena macro que deve ler todas as células de uma coluna (A), verificar a existência ou não de um conteúdo em cada célula ("Foto do perfil") e, caso positivo, escrever uma mensagem ("POSSUI NOME") na célula da coluna ao lado.

Utilizando outra pequena macro como referência, escrevi o código abaixo, mas ele não está funcionando corretamente. Como resultado, a macro acaba escrevendo em toda a coluna B a mensagem e não apenas nas que possuem o conteúdo pesquisado na célula da coluna A. Segue bloco do código:
Código: Selecionar todos
Sub TestarNomePerfil()
    Dim s As String, Count As Integer
    Let Application.ScreenUpdating = False
    Let s = "Foto do perfil"
    For Count = 1 To ActiveSheet.UsedRange.Rows.Count
        Set f = Cells.Find(s, LookIn:=xlValues)
        If Not f Is Nothing Then
            Cells(Count, 2).Value = "POSSUI NOME"
            Let Application.ScreenUpdating = True
         End If
    Next Count
End Sub
A macro que utilizei como referência está funcionando corretamente (apesar de ser bem lenta). Ela verifica a existência de um conteúdo ("Foto do perfil") e, caso positivo, apaga a linha. Repetindo que esta macro funciona normal. Segue ela:
Código: Selecionar todos
 Sub DeletarLinha()
    Dim s As String, Count As Integer
    Let Application.ScreenUpdating = False
    Let s = "Foto do perfil"
    For Count = 1 To ActiveSheet.UsedRange.Rows.Count
        Set f = Cells.Find(s, LookIn:=xlValues)
        If Not f Is Nothing Then
            f.EntireRow.Delete
            Let Application.ScreenUpdating = True
        End If
    Next Count
End Sub
Enfim, alguém poderia me ajudar a entender o que está acontecendo e, se possível, corrigir o problema?
Um abraço a todos!

Re: Erro em macro para pesquisar conteúdo e escrever mensage

Enviado: 30 Mai 2019 às 08:25
por osvaldomp
Experimente:
Código: Selecionar todos
Sub InsereTexto()
 Dim x As Long, LR As Long
  Application.ScreenUpdating = False
   With ActiveSheet
    .AutoFilterMode = False
    LR = .Cells(Rows.Count, 1).End(3).Row
    .[A1].AutoFilter 1, "*Foto de Perfil*"
     x = .Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).Count
           If x > 1 Then Range("B2:B" & LR).Value = "POSSUI NOME"
    .AutoFilterMode = False
   End With
  Application.ScreenUpdating = True
End Sub

Re: Erro em macro para pesquisar conteúdo e escrever mensage

Enviado: 30 Mai 2019 às 10:55
por duucerqueira
Oi, Osvaldo! Joia?
Muito obrigado pela disposição em ajudar, mas... não funcionou.
O seu código também está exibindo a mensagem em toda a coluna B, e não apenas nas células que possuem de fato a informação pesquisada na célula vizinha da A. :cry:

Erro em macro para pesquisar conteúdo e escrever mensagem

Enviado: 30 Mai 2019 às 11:24
por Reinaldo
Duas possibilidades:
Sua rotina alterada:
Código: Selecionar todos
Sub TestarNomePerfil()
Dim S As String, Count As Integer
Let Application.ScreenUpdating = False
Let S = "Foto do perfil"
For Count = 1 To ActiveSheet.UsedRange.Rows.Count
    Set f = Cells.Find(S, LookIn:=xlValues, looat:=xlPart)
    If Not f Is Nothing Then
        f.Select
        Selection.Offset(0, 1).Value = "POSSUI NOME"
        Let Application.ScreenUpdating = True
     End If
Next Count
End Sub
ou ainda:
Código: Selecionar todos
Sub tt()
Dim S As String, Count As Integer

For Count = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    'Verifica se o valor é igual ao procurado para exclusão
    If Cells(i, "A").Value Like "*" & S & "*" Then
        Cells(i, "B").Value = "POSSUI NOME"
    End If
Next
End Sub

Re: Erro em macro para pesquisar conteúdo e escrever mensage

Enviado: 30 Mai 2019 às 13:33
por osvaldomp
Não é necessário Loop.
Veja o arquivo anexado.

Re: Erro em macro para pesquisar conteúdo e escrever mensage

Enviado: 31 Mai 2019 às 03:03
por duucerqueira
Reinaldo e Osvaldo, muito obrigado!
Ambos os códigos que escreveram funcionaram!
Valeu! :)