Ir ao conteúdo
  • Cadastre-se
Jéssica De Moura Lima

Excel Macro para copiar e colar células não vazias de certas colunas

Recommended Posts

Prezados,

 

Gostaria de copiar dados de colunas específicas (células não vazias) e colar em outra guia. Com este código, apenas os dados da primeira coluna são copiados e colados.

 

Alguém poderia me ajudar?

 

Sub Registrar_fixos()

Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Dim lin As Long

Set Sht1 = Sheets("Contratos Fixos")
Set Sht2 = Sheets("Controle de Faturamento")


lin = 14


Application.ScreenUpdating = False

 

'Desbloquear guia e pasta de trabalho
ThisWorkbook.Unprotect ("123")
Sht1.Unprotect ("123")
Sht2.Unprotect ("123")


'Copiar coluna "Nº Pedido"
Sht1.Activate
While Sht1.Cells(lin, 3) <> ""
    Sht1.Cells(lin, 3).Copy
 
'Colar coluna "Nº Pedido"
Sht2.Activate
Sht2.Range("B9").Select
Do
    If ActiveCell <> "" Then
    ActiveCell.Offset(1, 0).Select
    End If

Loop Until ActiveCell = ""

ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Projeto"
Sht1.Activate
While Sht1.Cells(lin, 4) <> ""
    Sht1.Cells(lin, 4).Copy
 
    'Colar coluna "Projeto"
    Sht2.Activate
    Sht2.Range("C9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Nº Item"
Sht1.Activate
While Sht1.Cells(lin, 5) <> ""
    Sht1.Cells(lin, 5).Copy
 
    'Colar coluna "Nº Item"
    Sht2.Activate
    Sht2.Range("D9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Item"
Sht1.Activate
While Sht1.Cells(lin, 6) <> ""
    Sht1.Cells(lin, 6).Copy
 
    'Colar coluna "Item"
    Sht2.Activate
    Sht2.Range("E9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Cliente Raiz"
Sht1.Activate
While Sht1.Cells(lin, 7) <> ""
    Sht1.Cells(lin, 7).Copy
 
    'Colar coluna "Cliente Raiz"
    Sht2.Activate
    Sht2.Range("F9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Tipo de Contrato"
Sht1.Activate
While Sht1.Cells(lin, 21) <> ""
    Sht1.Cells(lin, 21).Copy
 
    'Colar coluna "Tipo de Contrato"
    Sht2.Activate
    Sht2.Range("G9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend


'Copiar coluna "Valor a Faturar (BRL)"
Sht1.Activate
While Sht1.Cells(lin, 20) <> ""
    Sht1.Cells(lin, 20).Copy
 
    'Colar coluna "Valor a Faturar (BRL)"
    Sht2.Activate
    Sht2.Range("H9").Select
    Do
        If ActiveCell <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If
    Loop Until ActiveCell = ""

    ActiveCell.PasteSpecial xlPasteValues

lin = lin + 1

Wend

Application.CutCopyMode = False

Sht1.Activate
 
'Atualizar status da guia "Contratos Fixos"
Sht1.Range("D9").Value = "p"

'Bloquear guia e pasta de trabalho
ThisWorkbook.Protect Password:="123", Structure:=True, Windows:=False
    
Sht1.Protect Password:="123", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterfaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=True, _
    AllowInsertingColumns:=False, _
    AllowInsertingRows:=True, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=True, _
    AllowSorting:=False, _
    AllowFiltering:=True, _
    AllowUsingPivotTables:=False
    
Sht2.Protect Password:="123", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True, _
    UserInterfaceOnly:=True, _
    AllowFormattingCells:=False, _
    AllowFormattingColumns:=False, _
    AllowFormattingRows:=True, _
    AllowInsertingColumns:=False, _
    AllowInsertingRows:=True, _
    AllowInsertingHyperlinks:=False, _
    AllowDeletingColumns:=False, _
    AllowDeletingRows:=True, _
    AllowSorting:=False, _
    AllowFiltering:=True, _
    AllowUsingPivotTables:=False
    
Application.ScreenUpdating = True

MsgBox "Faturamento registrado com sucesso!"

End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×