Executar até a última célula preenchida

[SuperBond]

Estou tentando fazer uma macro na qual ela verificará os valores em uma coluna e fará certas operações com esses valores. Inicialmente eu tinha feito uma estrutura com For e Next(abaixo),

Sub Final()
Dim m As Long, n As Long, N2 As String
 For m = 2 To 61
      N1 = Cells(m, 2)
       Cells(i + 1, 16) = N1: i = i + 1
  Next m
 ActiveSheet.range("P:P").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

mas como a quantidade de valores nas colunas irá sempre variar, não é prático ficar trocando o valor final da variável  m. Eu preciso que a macro verifique automaticamente até a última célula preenchida. Tentei fazer usando a estrutura Do While Loop, mas o resultado não é o desejado, ela não escreve todos os valores, mas vai tipo escrevendo um e apagando o anterior, é até difícil de explicar. O código com Do While Loop:

Sub Final()
Dim m As Long, n As Long, N1 As String
 m = 2
 N1 = 2
 Do While N1 <> Empty
       Cells(i + 1, 16) = N1: i = i + 1
 m = m + 1
 ActiveSheet.range("P:P").RemoveDuplicates Columns:=1, Header:=xlNo
Loop
End Sub

 

[Visitante]

Olá, Super.

Veja se ajuda.

Sub FinalV2()
 Dim m As Range, i As Long
  For Each m In Range("B2", Cells(Rows.Count, "B").End(xlUp))
   If m.Value <> "" Then
    Cells(i + 1, 16) = m.Value: i = i + 1
  Next m
 ActiveSheet.Range("P:P").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

[SuperBond]

Ok, só coloquei um End If e ele rodou, mas os dados que estou manipulando estão formatados como texto e alguns valores têm um 0 antes. Assim:

05, 04, 099

E eu preciso que estes zeros estejam no resultado. O código ignora os zeros, trata tudo como número. Está saindo 5, 4, 99 etc

Aí tentei usar Text no Range, mas dá erro 424: O objeto é obrigatorio.

Sub FinalV2()
 Dim m As Range, i As Long
  For Each m In Range("B2", Cells(Rows.Count, "B").End(xlUp)).Text
    If m.Value <> "" Then
     Cells(i + 1, 16) = m.Value: i = i + 1
    End If
  Next m
 'ActiveSheet.Range("P:P").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

[Visitante]

Disponibilize uma amostra do seu arquivo com algumas linhas de dados.

Coloque os resultados que o código está gerando e coloque os resultados esperados.

[SuperBond]

Ok, estou postando de um celular, então nao posso postar a planilha, mas na planilha, na coluna B tenho os seguinte valores por ex.:

B

96

98

01

02

07

Digamos que eu queira somar 2 a cada um desses valores. O resultado que preciso, nesse caso e':

98

100

03

04

09

Observe que o zero a esquerda foi mantido, e e' isso que eu preciso que aconteca. Mas seu codigo tem saida assim:

 

98

100

3

4

9

O codigo esta eliminando os zeros. Nao e' isso o esperado.

[Visitante]

1 hora atrás, SuperBond disse:

Ok, estou postando de um celular, então nao posso postar a planilha,

 

Se quiser que eu continue tentando ajudar atenda ao solicitado no post #4, exatamente como foi solicitado.

[SuperBond]

Desculpe se pareceu folga minha. Bem, taí um print da pasta e também estou postando a planilha em questão. Os zeros de 09, 05, 08 e 01 tem que permanecer.

AMOSTRA.rar

[Visitante]

Se eu entendi bem o problema, esse código deve ajudar

 

Sub Main()
    Dim Linha   As Long
    Dim Texto   As String
    Dim Numero  As Long
    
    Linha = 3
    
    Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row
        Texto = Cells(Linha, 2).Value
        Numero = Val(Texto) + 2
        Cells(Linha, 2).Value = Format(Str(Numero), String(Len(Texto), "0"))
        Linha = Linha + 1
    Loop
    
End Sub

 

Aí estou verificando todas as linhas da coluna B e somando 2 aos números, considerando o formato

[SuperBond]

 

Obrigado, Alpheratz, mas executei sua macro e não aparece nenhum resultado 

[Visitante]

Eu não sabia exatamente o que você precisava, mas agora que vi o screen que você postou, fiz algumas adaptações no código e deu certo. Veja

 

Sub Main()
    Dim Linha   As Long
    Dim LinhaResultado As Long
    Dim Texto   As String
    
    Linha = 2
    LinhaResultado = 1
    
    Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row
        Texto = Cells(Linha, 2).Value
        Cells(LinhaResultado, 6).NumberFormat = "@"
        Cells(LinhaResultado, 6).Value = Format(Val(Texto), String(Len(Texto), "0"))
        Linha = Linha + 1
        LinhaResultado = LinhaResultado + 1
    Loop
    
End Sub

 

[Visitante]

Sub FinalV3()
 Columns(4) = "": Range("B2", Range("B2").End(xlDown)).Copy [D1]
 ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

 

[SuperBond]

10 horas atrás, Alpheratz disse:

Alpheratz funciona, obrigado, só queria entender algumas linhas do código. 

Pode me explicar essa linha? 

Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row

 

E se eu quiser que a macro compare os valores de duas colunas e achando dois iguais ela os escreve juntos como esta na coluna D, como seria o código? Observe que teve 2 itens da col A iguais aos da col B, aí ele escreveu juntos.

Do seu código tentei acrescentar um indice p/ cada celula a ser analisada, mas não teve resultado:

Sub Final()
    Dim Linha   As Long
    Dim LinhaResultado As Long
    Dim N1 As String, N2 As String, N3 As String
    Linha1 = 1
    Linha2 = 1
    LinhaResultado = 1
    
    Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row
        N1 = Cells(Linha1, 2).Value
        N2 = Cells(Linha2, 3).Value
        If N2 = N3 Then
        Cells(LinhaResultado, 16).NumberFormat = "@"
        Cells(LinhaResultado, 16).Value = Format(Val(N1 & N2), String(Len(N1 & N2), "0"))
        End If
        Linha1 = Linha1 + 1
        Linha2 = Linha2 + 1
        LinhaResultado = LinhaResultado + 1
    Loop
End Sub

 

 

 

 

 

[Visitante]

A linha

 

Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row

 

É o critério de parada do Loop. Esse while vai de 2 (atribuição da variável Linha) até Linha ser menor ou igual ao valor da ultima linha com valor.

 

Para procurar um valor repetido em outra coluna, você pode usar a função Find. Veja que eu faço uso dela no código abaixo onde a função Encontrou retorna um valor booleano.

 

Sub Main()
    Dim Linha           As Long
    Dim LinhaResultado  As Long
    Dim Texto           As String
    
    Linha = 2
    LinhaResultado = 1
    
    Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row
        Texto = Cells(Linha, 2).Value
        
        If Encontrou(Texto, Range("C:C")) = True Then
            Dim Copia As String
            Copia = Format(Texto, String(Len(Texto), "0"))
            Cells(LinhaResultado, 6).NumberFormat = "@"
            Cells(LinhaResultado, 6).Value = Copia & Copia
            LinhaResultado = LinhaResultado + 1
        End If
        
        Linha = Linha + 1
    Loop
    
End Sub


Function Encontrou(Valor As String, Coluna As Range) As Boolean
    Dim Tmp As String
    
    On Error GoTo Fim
    
    Tmp = Coluna.Find(Valor).Value
    
    Encontrou = True

Fim:
    If Err.Number = 91 Then
        Encontrou = False
    End If
End Function

 

[SuperBond]

Legal. Fiz algumas pequenas alterações, só em relação às colunas com que a macro vai operar. O estranho é que se tem 45 em A e 450 em B ele considera sendo o mesmo valor.

Se tem 045 em A e 450 em B ele faz uma duplicata de um resultado.

O RemoveDuplicates era pra eliminar essa duplicata. O código alterado é esse e o resultado está abaixo e o print dos resultados abaixo: 

Sub Main()
    Dim Linha           As Long
    Dim LinhaResultado  As Long
    Dim Texto           As String
    
    Linha = 1
    LinhaResultado = 1
    
    Do While Linha <= Range("A" & Rows.Count).End(xlUp).Row
        Texto = Cells(Linha, 1).Value
        
        If Encontrou(Texto, Range("B:B")) = True Then
            Dim Copia As String
            Copia = Format(Texto, String(Len(Texto), "0"))
            Cells(LinhaResultado, 6).NumberFormat = "@"
            Cells(LinhaResultado, 6).Value = Copia & Copia
            LinhaResultado = LinhaResultado + 1
        End If
        
        Linha = Linha + 1
    Loop
    'ActiveSheet.Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Function Encontrou(Valor As String, Coluna As Range) As Boolean
    Dim Tmp As String
    
    On Error GoTo Fim
    
    Tmp = Coluna.Find(Valor).Value
    
    Encontrou = True

Fim:
    If Err.Number = 91 Then
        Encontrou = False
    End If
End Function

[Visitante]

Sobre o questão do código considerar o mesmo valor, é só fazer uma pequena alteração na função Find para ela procurar pelo conteúdo completo, ficando assim:

 

Coluna.Find(What:=Valor, LookAt:=xlWhole).Value

 

[SuperBond]

Alpheratz,  eu não consegui implementar suas sugestões no meu código. Tentei de várias formas, menos a certa, claro. Acho que teria aninhar mais Do whiles e Finds para procurar em outras colunas, mas não estou acertando fazer isso.

Estava ate cogitando usar Pascal, que é uma linguagem com a qual tenho mais familiaridade, mas VBA é mais prático e tem mais recursos.  Vou explicar o que preciso: 

Tenho 6 colunas A, B, E, F,  I e J. Tem pares de caracteres em B iguais aos de E e pares caracteres de F iguais aos de I.

Cada duas colunas formam um par: AB, EF e IJ. 

O código precisa unir os pares conforme encontra essas igualdades, ate a ultima linha preenchida. No print voce vê que o que une dois pares de AB ao par de EF é o 09 e o que une EF ao par de IJ é o W4. 

O resultado deve ser:

3209W4ES

X409W4ES

 

 

O último código que testei foi esse, só qe o Excel trava com esse código:

Sub Main()
    Dim Linha1           As Long
    Dim LinhaResultado  As Long
    Dim C1 As String, C2 As String, C3 As String, C4 As String, C5 As String, C6 As String
    [L:L].ClearContents
    Linha1 = 2
    Linha2 = 2
    Linha3 = 2
    Linha4 = 2
    Linha5 = 2
    Linha6 = 2
    LinhaResultado = 1
    
    Do While Linha <= Range("B" & Rows.Count).End(xlUp).Row
        C1 = Cells(Linha1, 1).Value
        C2 = Cells(Linha2, 2).Value
        C3 = Cells(Linha3, 5).Value
        C4 = Cells(Linha4, 6).Value
        C5 = Cells(Linha5, 9).Value
        C6 = Cells(Linha6, 10).Value
        
        If Encontrou(C2, Range("E:E")) = True And Encontrou(C4, Range("I:I")) = True Then
            Dim Copia As String
            Copia = Format(C1 & C2 & C4 & N6, String(Len(C1 & C2 & C4 & N6), "0"))
            Cells(LinhaResultado, 12).NumberFormat = "@"
            Cells(LinhaResultado, 12).Value = Copia
            LinhaResultado = LinhaResultado + 1
        End If
        
        Linha1 = Linha1 + 1
        Linha2 = Linha2 + 1
        Linha3 = Linha3 + 1
        Linha4 = Linha4 + 1
        Linha5 = Linha5 + 1
        Linha6 = Linha6 + 1
    Loop
    'ActiveSheet.Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Function Encontrou(Valor As String, Coluna As Range) As Boolean
    Dim Tmp As String
    
    On Error GoTo Fim
    
    Tmp = Coluna.Find(What:=Valor, LookAt:=xlWhole).Value
    
    Encontrou = True

Fim:
    If Err.Number = 91 Then
        Encontrou = False
    End If
End Function

 

[Visitante]

Com base no último screen que você postou, fiz outro código e acho que agora deu certo.

 

Sub Main()
    Dim Celula      As Range
    Dim Referencia  As Range
    Dim Tmp         As Range
    Dim StrValor    As String
    Dim VF          As Boolean
    
    For Each Celula In Range("B2:" & Range("B" & Rows.Count).End(xlUp).Address)
        Set Tmp = Celula
        VF = False
        
        While Encontrou(Tmp, Tmp.Offset(0, 3).EntireColumn, Referencia) = True
            If VF = False Then
                StrValor = Tmp.Offset(0, -1) & Tmp
                VF = True
            End If
            
            Set Tmp = Referencia.Offset(0, 1)
            StrValor = StrValor & Tmp
        Wend
        
        If VF = True Then
            Cells(Range("L" & Rows.Count).End(xlUp).Row + 1, 12) = StrValor
        End If
        
        StrValor = ""
    Next Celula
End Sub

Function Encontrou(ByVal Valor As String, ByVal Coluna As Range, Referencia As Range) As Boolean
    Dim Tmp As String
    
    If Valor = "" Then GoTo Fim
    On Error GoTo Fim
    Tmp = Coluna.Find(What:=Valor, LookAt:=xlWhole)
    Set Referencia = Coluna.Find(What:=Valor, LookAt:=xlWhole)
    Encontrou = True
Fim:
    If Err.Number = 91 Then
        Encontrou = False
    End If
End Function

 

[SuperBond]

Agora sim hem phera.  Obrigado 

Um dia desenvolvo sozinho...um dia chego lá. Uma última dúvida: tem como rodar a macro estando na janela do Excel mesmo, sem ter que ir na janela do VBA e dar F5? Seria mais prático.  

[Visitante]

Para rodar a macro sem ter que ir no editor, você pode usar um botão, forma, menu, etc. e associar com a macro.

 

Para associar a um retângulo, por exemplo, vá em Inserir > Formas e desenhe o retângulo. Depois clique com o botão direito sobre ele a escolha atribuir macro. Aí é só escolher a macro.

 

Feito isso, toda vez que você clicar sobre o retângulo, a macro será executada.

[SuperBond]

@Alpheratz

Me parece que o código está fazendo combinações inválidas. Conforme mostro em amarelo no print, nas colunas correspondentes do COD3 não tem o par 0UQA e nem R48I, então ele não poderia fazer 4W0UQA e 22R48I. Testei apenas com numeros e também ocorrem combinações inválidas.

 

[Visitante]

Eu achei que fosse para copiar o par sempre que houvesse pelo menos um código igual.

 

Deixa eu ver se entendi, caso a coluna B tenha um valor repetido na coluna E, mas não tenha repetição entre F e I, o programa deve copiar apenas o valore de A?

 

E a saída M8M8R4H9, está certa? H9 não repete.

 

 

Outra dúvida,

 

Por exemplo, na coluna E o código W4 aparece duas vezes... Nesses casos a macro está pegando o primeiro que aparece. É isso mesmo?

[SuperBond]

Na verdade o código formou combinações inválidas e me parece que deixou de formar combinações válidas, mas por hoje estou encerrando o trabalho. Vou deixar um print onde tracei a formação da combinação M8M8R4H9, que sim, é válida. A lógica é sempre a mesma.

 

 

 

[SuperBond]

O código deixou de fazer, por exemplo, M8M8R4SX, M8M8R4S0, M84W4W4W, W3M8R4H9, entre outras que são válidas. E fez combinações invalidas, como já vimos.

Outra coisa é que, sempre que executa a macro, ele não apaga os resultados anteriores, ele escreve a partir dos anteriores, dando a impressão de que há mais resultados do que deveria, mas isso eu resolvi colocando um ClearContents no início, logo depois do cabeçalho.

[L:L].ClearContents

 

[Visitante]

Sobre o problema de não pegar algumas combinações, como M84W4W4W, é por causa do que eu ei falei sobre a macro pegar apenas o primeiro caso quando repete.

 

Vou dar uma olhada aqui para corrigir o código