Excel copia e transferir dados vba

[RAIMUNDO LIMA DE ARAUJO]

Prezados, bom dia!

 

Venho solicita ajuda dos senhores(as), eu recebo em PDF todos os dia o plano de faturamento dos vagões, porém, como utilizo SAP e não sei programação VBA, demoro inserir os dados manuamente. Na empresa não consigo usar o powerquery por causa da versão, então, a alternativa seria, tratar os dados da planilha original para outra sheets, assim eu conseguiria copia de uma unica vez os dados e colar no SAP. 

Se for possível, copiar os dados que estão na ordem da planilha e colar em outra sheeets. 

OBSERVAÇÃO:

AQUIVO 2 É A PLANILHA ORIGINAL APOS CONVERSÃO PDF PARA EXCEL 

COLOCAR BOTÃO PARA SELECIONAR O ARQUIVO 2 E FAZER O TRATAMENTO DOS DADOS. 

1) tirar os traçõs 

2) Se for TCC somente os 4 ultimos numeros

3) se for TCT considerar todos os numeros 

4) remover as linhas em brancos

Segue arquivo e observações. 

@Patropi

 

LADO A PLANILHA DE VAGÕES.xlsx

PLANILHA ORINAL APOS CONVERTER PDF PARA EXCEL.xlsx

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO Crie um módulo e cole o código abaixo.

 

Essa é a primeira parte da programação, peço que teste pra ver se há algum ajuste a fazer, logo envio o código completo.

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range



    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If


         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         Windows("LADO A PLANILHA DE VAGÕES.xlsm").Activate
        
    Plan1.Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
End Sub

 

[Scofieldgyn]

6 horas atrás, Scofieldgyn disse:

@RAIMUNDO LIMA DE ARAUJO Crie um módulo e cole o código abaixo.

 

Essa é a primeira parte da programação, peço que teste pra ver se há algum ajuste a fazer, logo envio o código completo.

 

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range

 

    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If

         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         Windows("LADO A PLANILHA DE VAGÕES.xlsm").Activate
        
    Plan1.Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
End Sub
 

 

 

segue o código completo.

Não esqueça de salvar como pasta de trabalho habilitada para macro.

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range

    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If


         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         Windows("LADO A PLANILHA DE VAGÕES.xlsm").Activate
        
    Plan1.Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
    Plan1.Select
    
    UltLin = Range("A5").End(xlDown).Row - 2 'identificar última célula preenchida
    Plan1.Range("A5:A" & UltLin).Copy Plan2.Range("A6")
    Plan1.Range("C5:C" & UltLin).Copy Plan2.Range("C6")
    Plan1.Range("F5:F" & UltLin).Copy Plan2.Range("D6")
    Plan1.Range("J5:J" & UltLin).Copy Plan2.Range("E6")
    Plan1.Range("L5:L" & UltLin).Copy Plan2.Range("F6")
    Plan1.Range("M5:M" & UltLin).Copy Plan2.Range("G6")
    Plan1.Range("N5:N" & UltLin).Copy Plan2.Range("H6")
    Plan1.Range("Q5:Q" & UltLin).Copy Plan2.Range("I6")
    Plan1.Range("S5:S" & UltLin).Copy Plan2.Range("J6")
    Plan1.Range("T5:T" & UltLin).Copy Plan2.Range("K6")
    
    Plan2.Select
    UltLin = Range("A6").End(xlDown).Row
    Range("B6:B" & UltLin).FormulaR1C1 = "=IF(LEFT(ORIGINAL!R[-1]C,3)=""TCC"",SUBSTITUTE(RIGHT(ORIGINAL!R[-1]C,5),""-"",""""),ORIGINAL!R[-1]C)"
    
    Range("B6:B" & UltLin).Copy
    Range("B6:B" & UltLin).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Range("A" & UltLin + 1 & ":K1048576").Select 'Após colar as fórmulas limpar a partir da ultima celuLa vazia
    Selection.Clear
    
End Sub

 

[RAIMUNDO LIMA DE ARAUJO]

7 horas atrás, Scofieldgyn disse:

 

 

segue o código completo.

Não esqueça de salvar como pasta de trabalho habilitada para macro.

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range

    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If


         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         Windows("LADO A PLANILHA DE VAGÕES.xlsm").Activate
        
    Plan1.Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
    Plan1.Select
    
    UltLin = Range("A5").End(xlDown).Row - 2 'identificar última célula preenchida
    Plan1.Range("A5:A" & UltLin).Copy Plan2.Range("A6")
    Plan1.Range("C5:C" & UltLin).Copy Plan2.Range("C6")
    Plan1.Range("F5:F" & UltLin).Copy Plan2.Range("D6")
    Plan1.Range("J5:J" & UltLin).Copy Plan2.Range("E6")
    Plan1.Range("L5:L" & UltLin).Copy Plan2.Range("F6")
    Plan1.Range("M5:M" & UltLin).Copy Plan2.Range("G6")
    Plan1.Range("N5:N" & UltLin).Copy Plan2.Range("H6")
    Plan1.Range("Q5:Q" & UltLin).Copy Plan2.Range("I6")
    Plan1.Range("S5:S" & UltLin).Copy Plan2.Range("J6")
    Plan1.Range("T5:T" & UltLin).Copy Plan2.Range("K6")
    
    Plan2.Select
    UltLin = Range("A6").End(xlDown).Row
    Range("B6:B" & UltLin).FormulaR1C1 = "=IF(LEFT(ORIGINAL!R[-1]C,3)=""TCC"",SUBSTITUTE(RIGHT(ORIGINAL!R[-1]C,5),""-"",""""),ORIGINAL!R[-1]C)"
    
    Range("B6:B" & UltLin).Copy
    Range("B6:B" & UltLin).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Range("A" & UltLin + 1 & ":K1048576").Select 'Após colar as fórmulas limpar a partir da ultima celuLa vazia
    Selection.Clear
    
End Sub

 

BOA NOITE, 

 

Deu esse erro @Scofieldgyn

 

olha esse aqui com varios vagões kkkk

lado b planilha de vagoes 09-08.xlsx

LADO B PLANILHA DE VAGOES 09-08.xlsx

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO Você anexou dois arquivos identicos.

 

Alterei uma das linhas do códigos, favor testar:

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range

    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If


         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         ActiveWorkbook.Activate
        
    Plan1.Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
    Plan1.Select
    
    UltLin = Range("A5").End(xlDown).Row - 2 'identificar última célula preenchida
    Plan1.Range("A5:A" & UltLin).Copy Plan2.Range("A6")
    Plan1.Range("C5:C" & UltLin).Copy Plan2.Range("C6")
    Plan1.Range("F5:F" & UltLin).Copy Plan2.Range("D6")
    Plan1.Range("J5:J" & UltLin).Copy Plan2.Range("E6")
    Plan1.Range("L5:L" & UltLin).Copy Plan2.Range("F6")
    Plan1.Range("M5:M" & UltLin).Copy Plan2.Range("G6")
    Plan1.Range("N5:N" & UltLin).Copy Plan2.Range("H6")
    Plan1.Range("Q5:Q" & UltLin).Copy Plan2.Range("I6")
    Plan1.Range("S5:S" & UltLin).Copy Plan2.Range("J6")
    Plan1.Range("T5:T" & UltLin).Copy Plan2.Range("K6")
    
    Plan2.Select
    UltLin = Range("A6").End(xlDown).Row
    Range("B6:B" & UltLin).FormulaR1C1 = "=IF(LEFT(ORIGINAL!R[-1]C,3)=""TCC"",SUBSTITUTE(RIGHT(ORIGINAL!R[-1]C,5),""-"",""""),ORIGINAL!R[-1]C)"
    
    Range("B6:B" & UltLin).Copy
    Range("B6:B" & UltLin).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Range("A" & UltLin + 1 & ":K1048576").Select 'Após colar as fórmulas limpar a partir da ultima celuLa vazia
    Selection.Clear
    
End Sub

 

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

deu essa mensagem. 
 

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO Tente novamente:

 

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim Planilha As String
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range


    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With
    
    
    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    Planilha = ActiveWorkbook.Name
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
    
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If


         Cells.Select

         Selection.UnMerge
         Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
         
    UltLin = Range("A4").End(xlDown).Row 'identificar última célula preenchida
    Range("A4:T" & UltLin).Copy

    
         'Colar na Planilha original
         
         Windows(Planilha).Activate
         Plan1.Select
         
         Range("A5").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste
            
         Application.CutCopyMode = False
         
importWorkbook.Close
       
    
    Plan1.Select
    
    UltLin = Range("A5").End(xlDown).Row - 2 'identificar última célula preenchida
    Plan1.Range("A5:A" & UltLin).Copy Plan2.Range("A6")
    Plan1.Range("C5:C" & UltLin).Copy Plan2.Range("C6")
    Plan1.Range("F5:F" & UltLin).Copy Plan2.Range("D6")
    Plan1.Range("J5:J" & UltLin).Copy Plan2.Range("E6")
    Plan1.Range("L5:L" & UltLin).Copy Plan2.Range("F6")
    Plan1.Range("M5:M" & UltLin).Copy Plan2.Range("G6")
    Plan1.Range("N5:N" & UltLin).Copy Plan2.Range("H6")
    Plan1.Range("Q5:Q" & UltLin).Copy Plan2.Range("I6")
    Plan1.Range("S5:S" & UltLin).Copy Plan2.Range("J6")
    Plan1.Range("T5:T" & UltLin).Copy Plan2.Range("K6")
    
    Plan2.Select
    UltLin = Range("A6").End(xlDown).Row
    Range("B6:B" & UltLin).FormulaR1C1 = "=IF(LEFT(ORIGINAL!R[-1]C,3)=""TCC"",SUBSTITUTE(RIGHT(ORIGINAL!R[-1]C,5),""-"",""""),ORIGINAL!R[-1]C)"
    
    Range("B6:B" & UltLin).Copy
    Range("B6:B" & UltLin).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Range("A" & UltLin & ":K1048576").Select 'Após colar as fórmulas limpar a partir da ultima celuLa vazia
    Selection.Clear
    
    With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    End With
    
End Sub

 

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

bom dia, 

deu esse erro. 

 

gostaria de fica-se assim a planilha tratada

 

se começar tcc tira o - e fica apenas o 4 ultimos numeros

se começar tct tira o - porém fica todos os numeros. 

 

planlha tratada

 

 

planlha original em anexo teste

 

planilha orinal apos converter pdf para excel (1).xlsx

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO

 

Fiz os testes aqui e está rodando, utilize esse arquivo estou anexando.

PLANILHA ORINAL APOS CONVERTER PDF PARA EXCEL (1).rar

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

bom dia, meu amigo, deu certo sim, so ajuste.

desculpe incomodar novamente, na coluna volume ambiente retornou o cliente, poderia ajustar para trazer o volume? 

se possível, poderia acrescentar outra regra. 

 

Se iniciar TCC, tira o - e fica o 4 ultimos numero

Se iniciar TCT, tira apenas o - 

em densidade, poderia colocar o 0,7080 para frente? ex: 708,00

 

 

 

 

 

 

Obrigado pelo suporte

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO

Teste agora...

PLANILHA ORINAL APOS CONVERTER PDF PARA EXCEL (1).rar

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn Obrigado meu amigo. 

Deus abençõe, resolvido!

[RAIMUNDO LIMA DE ARAUJO]

Poderia me ajudar no ultimo ajuste? 

 

importei a planilha em anexo porém apresentou erro para os vagões que iniciam com TCC

 

Gostaria que ficasse, 

se for TCC, tira o separador (-) e fica os 4 ultimos numeros

se for TCT tira o separador (-), porém, mantem todos os numeros. 

 

 

 

 

VAGOES FTL SABBA 16.11.xlsx

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO Qual erro?

 

 

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

 

O ARQUIVO EM ANEXO TEM 6 VAGÕES TCC, PODERIA FAZER TESTE? QUANDO É TCT, VI QUE DEU CERTO.

 

ERRO FOTO 01

VAGOES TCC.xlsx

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO

 

Fiz uma modificação no código, porém esse arquivo exemplo que mandou por último não está seguindo a mesma ordem de colunas conforme o primeiro, portanto você deverá definir novamente quais as ordens pra copiar as colunas pra ajustar na rotina. Caso houver variabilidade, ai código não ficará funcional.

Sub Importar()

Dim importFileName As Variant
Dim importWorkbook As Workbook
Dim importSheet As Worksheet
Dim Planilha As String
Dim importRange As Range
Dim UltLin As Long
Dim vRange As Range

    With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With
    
    Planilha1.Activate
    Range("A6:T1048576").EntireRow.Select
    Selection.Delete

    ' mostrar a caixa de diálogo de arquivo aberto
    importFileName = Application.GetOpenFilename(FileFilter:="Arquivo do Excel (*.xls; *.xlsx), *.xls;*.xlsx", Title:="Escolha um arquivo do Excel")
    Planilha = ActiveWorkbook.Name
    
    'se o usuário pressionou o botão cancelar: sair
    If importFileName = False Then Exit Sub
    
    Application.ScreenUpdating = False
         ' se o usuário selecionou um arquivo excel, abra-o
         Set importWorkbook = Application.Workbooks.Open(importFileName)
         Set importSheet = importWorkbook.Worksheets(1)
         
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
    End If

    Range("A4:Q5").Select
    Selection.AutoFilter
    UltLin2 = Range("A6").End(xlDown).Row 'identificar última célula preenchida

    With ActiveSheet
        .UsedRange
        UltLin2 = .Cells.SpecialCells(xlCellTypeLastCell).Row
        Set vRange = .Range("A6", .Cells(UltLin2, "A"))
        vRange.AutoFilter Field:=1, Criteria1:="="
        vRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData     ' Limpa todos os filtros da planilha
        End If
        .UsedRange
    End With

    Range("A6:Q1048576").EntireRow.Select
    Selection.UnMerge
         
    UltLin = Range("A6").End(xlDown).Row 'identificar última célula preenchida
    Range("A6:T" & UltLin).Copy
    
     Windows(Planilha).Activate
     Planilha1.Select
     [A6].PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
     SkipBlanks:=False, Transpose:=False
     ActiveSheet.Paste
     Application.CutCopyMode = False
         
    importWorkbook.Close
       
    Planilha1.Select
    UltLin = Range("A6").End(xlDown).Row - 2 'identificar última célula preenchida
    Planilha1.Range("A6:A" & UltLin).Copy Planilha2.Range("A6")
    Planilha1.Range("B6:B" & UltLin).Copy Planilha2.Range("B6")
    Planilha1.Range("C6:C" & UltLin).Copy Planilha2.Range("C6")
    Planilha1.Range("J6:J" & UltLin).Copy Planilha2.Range("D6")
    Planilha1.Range("Q6:Q" & UltLin).Copy Planilha2.Range("E6")
    Planilha1.Range("M6:M" & UltLin).Copy Planilha2.Range("G6")
    Planilha1.Range("N6:N" & UltLin).Copy Planilha2.Range("H6")
    Planilha1.Range("S6:S" & UltLin).Copy Planilha2.Range("I6")
    Planilha1.Range("T6:T" & UltLin).Copy Planilha2.Range("J6")
    
    Planilha2.Select
    UltLin = Range("A6").End(xlDown).Row
    Range("B6:B" & UltLin).FormulaR1C1 = _
    "=IF(LEFT('Table 1'!RC,3)=""TCC"",""TCC""&SUBSTITUTE(RIGHT('Table 1'!RC,5),""-"",""""),IF(LEFT('Table 1'!RC,3)=""TCT"",SUBSTITUTE('Table 1'!RC,""-"","""")))"
    Range("F6:F" & UltLin).FormulaR1C1 = "='Table 1'!RC[6]*1000"
    
    Range("B6:B" & UltLin).Copy
    Range("B6:B" & UltLin).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    
    Range("A" & UltLin & ":K1048576").Select 'Após colar as fórmulas limpar a partir da ultima celuLa vazia
    Selection.Clear
    
    Range("A6:T1048576").EntireRow.Select
        With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    End With

    
End Sub

 

 

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

Obrigado 

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

olá, será se é problema na configuração do meu excel? o codigo para vagão TCC não removeu as linhas em brando, não tirou o traço e não deixou so os 4 ultimos numero. 

EX: TCC0311

 

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO Este problema é somente agora que está tendo ou desde quando te forneci o código?

 

Anexe essa planilha que está tendo problema pra verificar.

[RAIMUNDO LIMA DE ARAUJO]

@Scofieldgyn

FALA MEU AMIGO, beleza? 

VOU GRAVAR O vídeo E ENVIAR, FICA MAS fácil, 

CODIGO VBA.zip

[Scofieldgyn]

@RAIMUNDO LIMA DE ARAUJO  Você um vídeo apenas mostrando que não está acessado o visual basic, esse é o problema?