Notifications
Clear all

Copiar número para outra planilha e verificar repetições.

6 Posts
2 Usuários
0 Reactions
1,320 Visualizações
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Boa tarde caros colegas,

Preciso mais uma vez de ajuda para resolver uma questão.
Necessito que seja copiado o número de registro da célula B1 (planilha Copiando para outra pasta) e colar na (planilha Numeros_de_reg_utilizados).
Depois verificar se o número de registro a ser copiado ja foi registrado na planilha Numeros_de_reg_utilizados, caso sim antes de copiar informar que este número já foi utilizado.
A parte de copiar e colar em outra planilha eu consegui fazer.
Mas preciso de ajuda para fazer a parte de verificar as repetições.
Por favor alguém poderia me ajudar?

Segue as planilhas em anexo.

Antecipadamente agradeço.

Abraços.

Fabiosp

 
Postado : 28/01/2016 8:26 am
(@srobles)
Posts: 231
Estimable Member
 

FabioSp,

Fiz as alterações no seu modelo. Veja se te atende.

Desabilitei a validação que você havia feito nela, e inclui uma rotina que já faz todo o serviço. Para que funcione corretamente, dentro do código, o caminho da pasta de destino (Numeros_de_reg_utilizados) foi informado, basta manter as duas pastas no mesmo lugar, senão, altere o caminho dela para onde desejar.

Aguardo retorno.

Abs

Espero ter ajudado.

Abs.

Saulo Robles

 
Postado : 28/01/2016 10:22 am
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

srobles boa tarde,

Muito obrigado por sua ajuda!
Era isso mesmo que precisava!!
Nossa! não imaginava que dava para fazer todo o processo com apenas uma rotina.
Só uma dúvida referente a planilha que vai ser copiado os números.
Para redirecionar o destino, devo incluir todo o endereço do diretório?
EX: "C:UsuariosfabiospDocumentosNumeros_de_reg_utilizados.xlsx

Mais uma vez obrigado!

Abraços.

Fabiosp

 Dim vRegistro As String
Dim planRegistros, planValidação As String
Sub validaRegistro()
    'Variavel para contar as linhas utilizadas
    Dim ultimaLinha As Integer
    'Desabilita atualização de tela
    Application.ScreenUpdating = False
    'Variavel com o nome da planilha principal
    planRegistros = ThisWorkbook.Name
    'Variavel com o valor da célula a ser pesquisada
    vRegistro = ThisWorkbook.Sheets("Registros").Range("B1")
    'Abre a outra planilha
    Workbooks.Open ThisWorkbook.Path & "Numeros_de_reg_utilizados.xlsx"
    'Variavel com o nome da planilha de destino
    planValidação = "Numeros_de_reg_utilizados.xlsx"
    
    'Com a pasta de destino, ativa a planilha com os registros usados
    With Windows(planValidação)
        .Activate
        'Com a planilha que contem os registros
        With Sheets("Num_Reg")
            .Activate
            Range("A1").Select
            Dim a  As Integer
            'Varre célula por célula na coluna A
            For a = 2 To .UsedRange.Rows.Count + 1
                'Variavel com o valor da célula atual
                Dim vCel As String
                vCel = Cells(a, "A")
                'Se o valor da célula for igual ao informado na planilha principal
                If vCel = vRegistro Then
                    'Exibe uma msg informando que o número já foi usado e pergunta se quer continuar
                    If MsgBox("Número de registro " & vRegistro & " já cadastrado!" & Chr(13) & _
                    "Prosseguir com a cópia?", vbQuestion + vbYesNo, "Cópia de registros") = vbYes Then
                        'Caso a resposta seja sim, grava os dados, salva e fecha a pasta de destino
                        Windows(planValidação).Activate
                        Sheets("Num_Reg").Activate
                        ultimaLinha = .UsedRange.Rows.Count + 1
                        Cells(ultimaLinha, "A") = vRegistro
                        MsgBox "Gravação de dados realizada com sucesso!", vbInformation, "Gravação de dados"
                        vRegistro = ""
                        Workbooks(planValidação).Close True
                        
                    'Caso a resposta seja não, sai da rotina
                    Else
                        MsgBox "Operação cancelada pelo usuário!", vbExclamation, "Gravação de dados"
                        Workbooks(planValidação).Close True
                        Application.ScreenUpdating = True
                        Exit Sub
                    End If
                Else
                    'Se a célula atual estiver em branco, grava os dados, salva e fecha a pasta de destino
                    If vCel = "" Then
                        Windows(planValidação).Activate
                        Sheets("Num_Reg").Activate
                         ultimaLinha = .UsedRange.Rows.Count + 1
                        Cells(ultimaLinha, "A") = vRegistro
                        MsgBox "Gravação de dados realizada com sucesso!", vbInformation, "Gravação de dados"
                        vRegistro = ""
                        Workbooks(planValidação).Close True
                    End If
                End If
            Next
            'Habilita a atualização de tela
            Application.ScreenUpdating = True
        End With
    End With
End Sub 
 
Postado : 28/01/2016 10:49 am
(@srobles)
Posts: 231
Estimable Member
 

Fabiosp,

Se as duas pastas estiverem no mesmo local, não precisa alterar, pois onde informei o caminho, o código se alto completa. EX : Workbooks.Open ThisWorkbook.Path & "Numeros_de_reg_utilizados.xlsx".

Como se pode notar, pedimos para abrir a planilha de destino com base no caminho da atual ThisWorkbook.Path.

Agora, se a principal estiver no desktop e a de destino em Meus Documentos, aí sim você deve alterar o caminho. Entendeu?

Abs

Espero ter ajudado.

Abs.

Saulo Robles

 
Postado : 28/01/2016 10:55 am
(@fabiosp)
Posts: 291
Reputable Member
Topic starter
 

Saulo Robles,
Obrigado pelos esclarecimentos.
Agora esta tudo perfeito!!
Agradeço a gentileza.

Abraços.

Fabiosp.

 
Postado : 28/01/2016 11:38 am
(@srobles)
Posts: 231
Estimable Member
 

Fabiosp,

Opa bom saber que ficou a contento, e precisando estamos aí para ajudar.

Abs

Espero ter ajudado.

Abs.

Saulo Robles

 
Postado : 28/01/2016 11:41 am