VBA copiar dados

[guilherme.utuari]

Boa tarde,

 

Procurei no fórum mas não encontrei nada que pudesse me ajudar.

Tenho uma planilha onde tenho uma base de dados, nela contém itens conformes e não conformes, o que preciso fazer é um vba que faça automaticamente sem a necessidade de botão que elas sejam copiadas para outras abas diferentes, ou seja, itens conformes (coluna D com status OK) sejam copiados para aba "Correct" e itens não conformes (coluna D com status Nok) sejam copiados para aba "Failures".

Porém preciso que sejam copiados apenas alguns algumas colunas, que seriam B;C;E;G da aba "data base" copiadas para A;B;C;D, das abas "failures" e "correct" também gostaria que fossem copiados as colunas F e H da aba "Data base" para as abas "Failures" e "Correct" na coluna E pois gostaria que concatenassem o que estiver escritos nas células para formar apenas uma,

exe: coluna F: nome da pessoa e coluna H: área de atuação  =

"nome da pessoa

area de atuação".

 

A planilha está em anexo, se alguém puder me ajudar, fico agradecido!

 

Att,

 

Guilherme.

Teste-Protótipo - Copy.xlsx

[Visitante]

Instale o código abaixo no módulo da planilha "Data base", assim:

 

1. copie o código daqui
2. clique com o direito na guia da planilha e escolha 'Exibir código'
3. cole o código na janela em branco que vai se abrir
4. feito! 'Alt+Q' para retornar para a planilha e testar

Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long  If Target.Count > 1 Then Exit Sub  If Target.Column <> 4 Or Target.Value = "" Then Exit Sub  If Target.Value = "Ok" Then   With Sheets("Correct")    LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)   End With  ElseIf Target.Value = "Nok" Then   With Sheets("Failures")    LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)   End With  End IfEnd Sub

 

[guilherme.utuari]

@osvaldomp

 

Obrigado cara, ajudou muito, mas tenho só mais duas dúvidas,

1 - seria possível que a planilha atualiza-se os dados? pois caso eu mudasse o status, ela automaticamente apagaria da aba colada e transferia para outra ou apagaria das duas.

2 - se escolho o status antes de digitar os dados do restantes, o vba já copia para outra aba mesmo sem eu ter completado a linha, ou seja, ficam com células vazias e quando eu digito o restante dos dados o vba copia na linha de baixo, seria possível que ele não fizesse isso? só copia-se se a linha estivesse preenchida ou no caso não for possível, inserir um botão para realizar o processo?

 

Obrigado pela ajuda!

[Visitante]

1 - seria possível que a planilha atualiza-se os dados? pois caso eu mudasse o status, ela automaticamente apagaria da aba colada e transferia para outra ou apagaria das duas.

É possível, adicionando os comandos ao código. Para isso você precisa indicar (ou criar em nova coluna) um identificador único (ID) para cada registro replicado. O comando para transferir um registro entre planilhas pode ser, por exemplo, alterando o status de "Ok" para "Nok" ou vice-versa, e para excluir um registro replicado poderia alterar o status para "NA".

 

2 - se escolho o status antes de digitar os dados do restantes, o vba já copia para outra aba mesmo sem eu ter completado a linha, ou seja, ficam com células vazias e quando eu digito o restante dos dados o vba copia na linha de baixo, seria possível que ele não fizesse isso? só copia-se se a linha estivesse preenchida ou no caso não for possível, inserir um botão para realizar o processo?

Substitua o código anterior pelo que está abaixo. O registro só será replicado se estiverem preenchidas as colunas "B" até "H".

 

Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long  If Target.Count > 1 Then Exit Sub  If Target.Column <> 4 Or Target.Value = "" Then Exit Sub  If (Target.Value = "Ok" Or Target.Value = "Nok") And _    Application.CountA(Target.Offset(, -2).Resize(, 7)) < 7 Then   MsgBox "REGISTRO INCOMPLETO. NÃO SERÁ REPLICADO": Exit Sub  End If  If Target.Value = "Ok" Then   With Sheets("Correct")    LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)   End With  ElseIf Target.Value = "Nok" Then   With Sheets("Failures")    LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)   End With  End IfEnd Sub

[guilherme.utuari]

Ficou perfeito o novo código, porém só não consegui compreender sobre a coluna que devo adicionar, preciso adicionar uma coluna a cada aba fazendo uma referência a o que foi copiado ou preciso adicionar uma coluna na aba data base para "criar" uma referência para cada linha?

 

Att,

 

Guilherme Utuari.

[Visitante]

É preciso criar um ID para cada registro. Claro, o ID deve ser único pois será o identificador do registro e será utilizado pelo código para buscar o respectivo registro nas planilhas "Failures" e "Correct".

Não vejo na sua planilha "Data base" nenhuma coluna que pudesse ser aproveitada como ID pois existe a possibilidade de repetição para vários registros, então, uma possibilidade é reservar naquela planilha a coluna "K", que atualmente não é utilizada, (ou outra coluna, se preferir) para armazenar o ID. O ID poderá ser gerado pelo código que postei, acrescentando a ele os comandos necessários.

Os usuários não utilizarão o ID portanto não precisam vê-lo, então você pode manter a coluna "K" com largura pequena e, se quiser, poderá colocar a cor da fonte igual à cor do preenchimento, tornando assim o ID invisível.

Na sequência, ao ser replicado nas planilhas "Failures" e "Correct", o ID seria armazenado na coluna "H" atualmente não utilizada, ou outra coluna se você preferir.

Para o funcionamento correto o usuário não poderá excluir linha, limpar a linha inteira e tampouco deletar o ID.

Então, se você concordar com a sugestão acima, a sua parte é definir, para as 3 planilhas, quais colunas deseja utilizar para armazenar o ID. Em seguida faremos a complementação do código.

[guilherme.utuari]

@osvaldomp concordo com sua sugestão, incluse em utilizar a coluna K para data base e as colunas H para as outras abas, como ficaria o código com a complementação?

[Visitante]

Guilherme, faça os testes com o código abaixo no lugar do anterior.

Private Sub Worksheet_Change(ByVal Target As Range) Dim LR As Long, RgRP As Range  If Target.Count > 1 Then Exit Sub  If Target.Column <> 4 Then Exit Sub  If (Target.Value = "Ok" Or Target.Value = "Nok") And _    Application.CountA(Target.Offset(, -2).Resize(, 7)) < 7 Then   MsgBox "REGISTRO INCOMPLETO. A OPERAÇÃO NÃO SERÁ EFETUADA": Target.Value = "NA": Exit Sub  End If ' ########### (Status = "NA" ou Status=vazio) e ID <> vazio If (Target.Value = "NA" Or Target.Value = "") And Target.Offset(, 7).Value <> "" Then  With Sheets("Correct")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     .Rows(RgRP.Row).Delete     Target.Offset(, 7).Value = "": Exit Sub    End If  End With  With Sheets("Failures")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     .Rows(RgRP.Row).Delete     Target.Offset(, 7).Value = ""    End If  End With  ' ###########   Status = "Ok" e ID = vazio ElseIf Target.Value = "Ok" And Target.Offset(, 7) = "" Then  Target.Offset(, 7).Value = Application.Max([K:K]) + 1  With Sheets("Correct")   LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)     .Cells(LR + 1, 8) = Target.Offset(, 7).Value  End With  ' ###########   Status = "Ok" e ID <> vazio ElseIf Target.Value = "Ok" And Target.Offset(, 7).Value <> "" Then  With Sheets("Correct")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     .Cells(RgRP.Row, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(RgRP.Row, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(RgRP.Row, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)    Else     LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)     .Cells(LR + 1, 8) = Target.Offset(, 7).Value    End If  End With  With Sheets("Failures")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     .Rows(RgRP.Row).Delete    End If  End With    ' ###########   Status = "Nok" e ID = vazio ElseIf Target.Value = "Nok" And Target.Offset(, 7) = "" Then  Target.Offset(, 7).Value = Application.Max([K:K]) + 1  With Sheets("Failures")   LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)     .Cells(LR + 1, 8) = Target.Offset(, 7).Value  End With  ' ###########   Status = "Nok" e ID <> vazio ElseIf Target.Value = "Nok" And Target.Offset(, 7).Value <> "" Then  With Sheets("Correct")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     .Rows(RgRP.Row).Delete    End If  End With  With Sheets("Failures")   Set RgRP = .Columns(8).Find(Target.Offset(, 7).Value, lookat:=xlWhole)    If Not RgRP Is Nothing Then     LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(RgRP.Row, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(RgRP.Row, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(RgRP.Row, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)    Else     LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = Target.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = Target.Offset(, 1).Value: .Cells(LR + 1, 4) = Target.Offset(, 3).Value     .Cells(LR + 1, 5) = Target.Offset(, 2).Value & Chr(10) & Target.Offset(, 4)     .Cells(LR + 1, 8) = Target.Offset(, 7).Value    End If  End With End IfEnd Sub

na planilha "Data base", para obter os seguintes resultados:
1. replicar registro na planilha destino >> preencha de "B" até "H" e passe o "Status" para "Ok" ou para "Nok"
2. excluir registro da planilha destino >> passe o "Status" para "NA" ou para vazio
3. trocar registro entre as planilhas destino >> alterne o "Status" entre "Ok" e "Nok"
 

[guilherme.utuari]

@osvaldomp deu certo! ficou show, muito obrigado!

[guilherme.utuari]

@osvaldomp Desculpe voltar ao tópico novamente, porém estou com um pequeno problema, gostaria de saber se é possível adicionar um botão para realizar a atualização dos dados paras as outras abas, pois como o relatório precisa ser gerado rápido, estamos com problemas em ter que selecionar a letra "G" ou "R" em cada linha e as vezes alteramos os dados e temos que ficar alterando cada célula para ser realizada a substituição.

Estou colocando a planilha em anexo.

 

Obrigado!

PROTOTYPE REPORT 2015 - REV II.zip

[Visitante]

... estou com um pequeno problema, gostaria de saber se é possível adicionar um botão para realizar a atualização dos dados paras as outras abas, pois como o relatório precisa ser gerado rápido, estamos com problemas em ter que selecionar a letra "G" ou "R" em cada linha e as vezes alteramos os dados e temos que ficar alterando cada célula para ser realizada a substituição.

Não sei do que você está falando...

Abri o seu arquivo em busca de explicações, exemplos, resultados desejados. Encontrei nada...

[guilherme.utuari]

Bom dia Osvaldo, o código que você fez para esta planilha, busca na aba "data base" as células que contém as letras "G" e "R" e realiza uma copia para as abas "Correct" e "Failures" respectivamente, porém, o input para está copia é a própria célula, ou seja, quando seleciono na célula uma das opções "G" ou "R" ele ativa o código e faz a cópia.

O problema que estou encontrando é, quando necessito realizar grandes mudanças, como por exemplo alterar 80 células com valor "G" para "R" preciso ir selecionando uma a uma para o código ser ativado e realizar a alteração, se eu "arrastar" o valor "G" ou "R" para as demais células, o código não funciona, por isso, gostaria de um código para inserir em um botão que quando eu clicasse ele vasculhasse as células na aba "Data base" e caso haja alguma mudança em alguma célula, "G" para "R" ou vice-versa ou alguma alteração nas outras células, ele atualizasse as abas "Correct" e "Failures".

[Visitante]

Guilherme, veja se é isso.
1. remova o código anterior do módulo da planilha "Data base"
2. instale o código abaixo em um módulo comum e coloque na planilha "Data base" o botão que para executá-lo.

funcionamento do código:
1. limpa os registros das planilhas "Correct" e "Failures", incluindo as fotos
2. replica na planilha "Correct" os registros existentes na planilha "Data base", iguais a "G" na coluna "D"
3. replica na planilha "Failures" os registros existentes na planilha "Data base", iguais a "R" na coluna "D"
 

Sub AtualizaCorrectFailures() Dim rngSour As Range, rngST As Range, LR As Long Dim fot As Object, wsCF As Worksheet, ws As String  For Each wsCF In ThisWorkbook.Sheets(Array("Correct", "Failures"))  With wsCF   LR = .Cells(Rows.Count, 1).End(xlDown).Row   .Range("A3:H" & LR).ClearContents    For Each fot In .Pictures     fot.Delete    Next fot  End With Next wsCF  Set rngSour = Range("D2", Cells(Rows.Count, "D").End(xlUp))   For Each rngST In rngSour   If rngST.Value = "G" Then    ws = "Correct"   ElseIf rngST.Value = "R" Then    ws = "Failures"   Else: GoTo nextrngST   End If    With Sheets(ws)     LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = rngST.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = rngST.Offset(, 1).Value: .Cells(LR + 1, 4) = rngST.Offset(, 3).Value     .Cells(LR + 1, 5) = rngST.Offset(, 2).Value & Chr(10) & rngST.Offset(, 4)    End WithnextrngST:  Next rngSTEnd Sub

[guilherme.utuari]

@osvaldomp é quase isso, a única diferença é que eu não gostaria que o código limpasse os dados e sim só atualizasse se houvesse alguma mudança na aba "Data Base". Só limpasse a linha caso as opções "G" e "R" fossem alteradas para vazias ou "N/A", igual você tinha feito, colocando uma referência em uma coluna para o excel conseguir fazer esta comparação.

[Visitante]

Experimente o código abaixo no lugar do anterior.

Sub AtualizaPlanilhas() Dim LR As Long, rngSour As Range, wsCF As Worksheet, rngST As Range, fot As Object, ws As String For Each wsCF In ThisWorkbook.Sheets(Array("Correct", "Failures"))  With wsCF   LR = .Cells(Rows.Count, 1).End(xlDown).Row   .Range("A3:H" & LR).Value = ""    For Each fot In .Pictures     fot.Delete    Next fot  End With Next wsCF  Set rngSour = Range("D2", Cells(Rows.Count, "D").End(xlUp))   For Each rngST In rngSour   If rngST.Value = "G" Then    ws = "Correct"   ElseIf rngST.Value = "R" Then    ws = "Failures"   Else: GoTo nextrngST   End If    With Sheets(ws)     LR = .Cells(Rows.Count, 1).End(xlUp).Row     .Cells(LR + 1, 1).Resize(, 2).Value = rngST.Offset(, -2).Resize(, 2).Value     .Cells(LR + 1, 3) = rngST.Offset(, 1).Value: .Cells(LR + 1, 4) = rngST.Offset(, 3).Value     .Cells(LR + 1, 5) = rngST.Offset(, 2).Value & Chr(10) & rngST.Offset(, 4)    End WithnextrngST:  Next rngSTEnd Sub

[guilherme.utuari]

@osvaldomp ficou muito bom! Apenas uma última dúvida, seria possível o vba realizar a atualização e não limpar as imagens? somente limpar a imagem caso o resto das informações for removido também?

[Visitante]

Guilherme, por favor disponibilize uma amostra do seu arquivo, com 4 a 5 registros replicados nas planilhas "Correct" e "Failures" (se quiser utilize o primeiro código para replicar os registros), com as respectivas figuras. Se você utiliza mais de um tipo de figura coloque ao menos uma amostra de cada tipo.

[guilherme.utuari]

@osvaldomp

 

Segue o anexo da planilha com alguns exemplos de preenchimento.

PROTOTYPE REPORT 2015 - REV III English.zip

[Visitante]

@guilherme, desculpe a demora.

Veja se ficou melhor.

Remova todos os códigos anteriores e experimente este.
Antes de rodar limpe as planilhas "Correct" e "Failures", inclusive a coluna "J" dessas planilhas que é utilizada pelo código para colocar o ID. Limpe também a coluna "K" da planilha "Data base".

Sub AtualizaPlanilhasV3() Dim LR As Long, LRo As Long, LRd As Long, i As Long, k As Long, rST As Range Dim wsCF As Worksheet, St As String, ws As Worksheet, rK As Range, rngST As Range St = "G": Set ws = Sheets("Data base") For Each wsCF In ThisWorkbook.Sheets(Array("Correct", "Failures"))  With wsCF   LR = .Cells(Rows.Count, 9).End(xlUp).Row   If LR < 3 Then GoTo nextwsCF   For i = LR To 3 Step -1    k = ws.Columns(11).Find(.Cells(i, 9), lookat:=xlWhole).Row    If ws.Cells(k, 4).Value <> St Then     .Rows(i).Delete     ws.Cells(k, 11).Value = ""    Else     .Cells(i, 1).Resize(, 2).Value = ws.Cells(k, 2).Resize(, 2).Value     .Cells(i, 3) = ws.Cells(k, 5): .Cells(i, 4) = ws.Cells(k, 7)     .Cells(i, 5) = ws.Cells(k, 6) & Chr(10) & ws.Cells(k, 8)    End If   Next i  End WithnextwsCF:  St = "R" Next wsCF   With ws   Application.ScreenUpdating = False   On Error Resume Next   .ShowAllData   LRo = .Cells(Rows.Count, 4).End(xlUp).Row   .Range("A1:K" & LRo).AutoFilter Field:=3, _   Criteria1:="=G", Operator:=xlOr, Criteria2:="=R"   LRo = .Cells(Rows.Count, 4).End(xlUp).Row   Set rngST = .Range("D2:D" & LRo).SpecialCells(xlCellTypeVisible)  For Each rST In rngST    If rST.Row = 1 Then .ShowAllData:  Application.ScreenUpdating = True: Exit Sub    If .Cells(rST.Row, 11) = "" Then     If .Cells(rST.Row, 4) = "G" Then Set wsCF = Sheets("Correct")     If .Cells(rST.Row, 4) = "R" Then Set wsCF = Sheets("Failures")     .Cells(rST.Row, 11) = Application.Max(.Columns("K")) + 1     LRd = wsCF.Cells(Rows.Count, 1).End(xlUp).Row     wsCF.Cells(LRd + 1, 1).Resize(, 2).Value = .Cells(rST.Row, 2).Resize(, 2).Value     wsCF.Cells(LRd + 1, 3) = .Cells(rST.Row, 5): wsCF.Cells(LRd + 1, 4) = .Cells(rST.Row, 7)     wsCF.Cells(LRd + 1, 5) = .Cells(rST.Row, 6) & Chr(10) & .Cells(rST.Row, 8)     wsCF.Cells(LRd + 1, 9) = .Cells(rST.Row, 11)    Else:     If .Cells(rST.Row, 4) = "N/A" Or .Cells(rST.Row, 4) = "" Then      On Error Resume Next      k = Sheets("Correct").Columns(9).Find(.Cells(rST.Row, 11), lookat:=xlWhole).Row      Sheets("Correct").Rows(k).Delete      k = Sheets("Failures").Columns(9).Find(.Cells(rST.Row, 11), lookat:=xlWhole).Row      Sheets("Failures").Rows(k).Delete      On Error GoTo 0      .Cells(rST.Row, 11) = ""     ElseIf .Cells(rST.Row, 4) = "G" Then      Set wsCF = Sheets("Correct")      Set rK = wsCF.Columns(9).Find(.Cells(rST.Row, 11), lookat:=xlWhole)      If Not rK Is Nothing Then       wsCF.Cells(rK.Row, 1).Resize(, 2).Value = .Cells(rST.Row, 2).Resize(, 2).Value       wsCF.Cells(rK.Row, 3) = .Cells(rST.Row, 5): wsCF.Cells(rK.Row, 4) = .Cells(rST.Row, 7)       wsCF.Cells(rK.Row, 5) = .Cells(rST.Row, 6) & Chr(10) & .Cells(rST.Row, 8)      Else       LRd = wsCF.Cells(Rows.Count, 1).End(xlUp).Row       wsCF.Cells(LRd + 1, 1).Resize(, 2).Value = .Cells(rST.Row, 2).Resize(, 2).Value       wsCF.Cells(LRd + 1, 3) = .Cells(rST.Row, 5): wsCF.Cells(LRd + 1, 4) = .Cells(rST.Row, 7)       wsCF.Cells(LRd + 1, 5) = .Cells(rST.Row, 6) & Chr(10) & .Cells(rST.Row, 8)       wsCF.Cells(LRd + 1, 9) = .Cells(rST.Row, 11)       k = Sheets("Failures").Columns(11).Find(.Cells(rST.Row, 9), lookat:=xlWhole).Row       Sheets("Failures").Rows(k).Delete      End If     Else      Set wsCF = Sheets("Failures")      Set rK = wsCF.Columns(9).Find(.Cells(rST.Row, 11), lookat:=xlWhole)      If Not rK Is Nothing Then       wsCF.Cells(rK.Row, 1).Resize(, 2).Value = .Cells(rST.Row, 2).Resize(, 2).Value       wsCF.Cells(rK.Row, 3) = .Cells(rST.Row, 5): wsCF.Cells(rK.Row, 4) = .Cells(rST.Row, 7)       wsCF.Cells(rK.Row, 5) = .Cells(rST.Row, 6) & Chr(10) & .Cells(rST.Row, 8)      Else       LRd = wsCF.Cells(Rows.Count, 1).End(xlUp).Row       wsCF.Cells(LRd + 1, 1).Resize(, 2).Value = .Cells(rST.Row, 2).Resize(, 2).Value       wsCF.Cells(LRd + 1, 3) = .Cells(rST.Row, 5): wsCF.Cells(LRd + 1, 4) = .Cells(rST.Row, 7)       wsCF.Cells(LRd + 1, 5) = .Cells(rST.Row, 6) & Chr(10) & .Cells(rST.Row, 8)       wsCF.Cells(LRd + 1, 9) = .Cells(rST.Row, 11)       Set rK = Sheets("Correct").Columns(9).Find(.Cells(rST.Row, 11), lookat:=xlWhole) '.Row       If Not rK Is Nothing Then Sheets("Correct").Rows(k).Delete      End If     End If    End IfnextrST:   Next rST   .ShowAllData  End With  Application.ScreenUpdating = TrueEnd Sub

[Patropi]

Guilherme

 

Para agradecer ao Osvaldo, clique no botão Curtir de cada resposta útil dele.

Em qualquer tópico, não precisa ser só no teu, quando achar a resposta útil, clique em Curtir para incentivar os colaboradores.

 

Quando a dúvida for sanada, clique também no Botão Resolvido para dar o tópico por Resolvido.

 

[]s

[guilherme.utuari]

@Patropi desculpe, esqueci de curtir.

@osvaldomp valeu cara! obrigado mesmo, ficou show!

[guilherme.utuari]

@osvaldomp Bom dia!

 

Cara, estou com um grande problema na planilha, quando acrescento muitos dados a planilha a macro bagunça a planilha inteira e consequentemente ocorre um erro, o que posso estar fazendo de errado? estou colocando a planilha com as informações antes de realizar a macro e após realizar.

Se puder me ajudar fico muito agradecido.

 

Obs: coloquei um botão azul "A" na aba "data base" para ativar a macro de copiar os dados.

 

Abraços!

 

Planilhas.zip

[Visitante]

 

Cara, estou com um grande problema na planilha, quando acrescento muitos dados a planilha a macro bagunça a planilha inteira

O que você quer dizer com "muitos dados" ?

O que você quer dizer com "a macro bagunça a planilha inteira" ?

"e consequentemente ocorre um erro," - Qual o erro que ocorre ?

 

o que posso estar fazendo de errado?

Se a quantidade de dados nas planilhas é continuamente aumentada a consequência normal é o aumento do tempo de execução do código. Só isso. O código não faz bagunça pra sacanear. Eu não fiscalizo o seu trabalho então não sei responder o que você fez de errado. Se o código antes funcionava, cabe a você informar o que foi alterado.

 

estou colocando a planilha com as informações antes de realizar a macro e após realizar.

Considere que o tico e teco aqui deletaram todas as informações anteriores sobre este seu tópico.

Então, disponibilize um único arquivo com somente as planilhas envolvidas no problema, exclua as demais.

É necessário que você descreva qual a finalidade do código, o resultado desejado e o resultado que está ocorrendo, a tal "bagunça".

Não é razoável você postar dois arquivos com trocentas planilhas, buzilhão de dados e transferir pra mim todo o trabalho.

 

[guilherme.utuari]

@osvaldomp desculpe pelo mal entendido, não quis transferir o trabalho pra você, de maneira alguma. Peço desculpas por estar vindo e voltando ao tópico, agradeço de verdade pela ajuda.

Bom, consegui resolver o problema, o que fiz errado foi simplesmente não apagar uma coluna que realizava uma espécie de "conferência" dos dados copiados.

Novamente, desculpe pelo mal entendido e muito obrigado pela ajuda.

 

Abraços.

[Visitante]

Beleza, Guilherme.

Fico contente     por você ter encontrado a origem do problema.

abraço