Macro para importar .xls II

Question

Amigos,

 

Tenho o seguinte código:

 

Sub ImportTextFile()

    Dim DestBook As Workbook, SourceBook As Workbook
    Dim DestCell As Range
    Dim RetVal As Boolean

    ' Turn off screen updating.
    Application.ScreenUpdating = False

    ' Set object variables for the active book and active cell.
    Set DestBook = ActiveWorkbook
    Range("A5").Activate
    Set DestCell = ActiveCell
   
    ' Show the Open dialog box.
    RetVal = Application.Dialogs(xlDialogOpen).Show("*.xls")

    ' If Retval is false (Open dialog canceled), exit the procedure.
    If RetVal = False Then Exit Sub

    ' Set an object variable for the workbook containing the text file.
    Set SourceBook = ActiveWorkbook

    ' Copy the contents of the entire sheet containing the text file.
    Range(Range("B1"), Range("B1").SpecialCells(xlLastCell)).Copy

    ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.PasteSpecial Paste:=xlValues

    ' Close the book containing the text file.
    SourceBook.Close False

End Sub

 

Preciso que, ao importar o arquivo, ele ignore apenas a linha 7 do arquivo origem. Is it possible?

 

Grato

 

Sds

Jerson

Answer 1

Olá,

Tente o código com as mudanças abaixo: primeiro copia as 6 primeiras linhas e depois da oitava até a última linha preenchida.

[ ]s

 

Code Snippet

Sub ImportTextFile()

    Dim DestBook As Workbook, SourceBook As Workbook
    Dim DestCell As Range
    Dim RetVal As Boolean

    ' Turn off screen updating.
    Application.ScreenUpdating = False

    ' Set object variables for the active book and active cell.
    Set DestBook = ActiveWorkbook
    Range("A5").Activate
    Set DestCell = ActiveCell
   
    ' Show the Open dialog box.
    RetVal = Application.Dialogs(xlDialogOpen).Show("*.xls")

    ' If Retval is false (Open dialog canceled), exit the procedure.
    If RetVal = False Then Exit Sub

    ' Set an object variable for the workbook containing the text file.
    Set SourceBook = ActiveWorkbook

    ' Copy the contents of the first six lines of the sheet containing the text file.
   
    'Last filled column in the SourceBook file
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
   
    'Last filled row in the SourceBook file
    LastLine = Cells(Rows.Count, 1).End(xlUp).Row
   
    Range(Cells(1, 2), Cells(6, LastColumn)).Copy
   
    ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.PasteSpecial Paste:=xlValues
   
    ' Copy the contents from the eighth line to the last line
    SourceBook.Activate
    Range(Cells(8, 2), Cells(LastLine, LastColumn)).Copy
   
    ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.PasteSpecial Paste:=xlValues

    ' Close the book containing the text file.
    SourceBook.Close False

End Sub

 

 

 

Answer 2

Adilson,

 

Este código copia apenas as 7 primeiras linhas. Consegui resolver o problema adicionando o seguinte código antes de "SourceBook.Close False":

 

Range("A7").Select

Selection.EntireRow.Delete

 

Mesmo assim, muito obrigado pela tentativa.

 

Um grande abraço!

 

Jerson

 

Answer 3

Jerson,

Descobri um problema no código.

Funciona se vc substituir as últimas linhas por:

 

    ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.Offset(6, 0).PasteSpecial Paste:=xlValues

    ' Close the book containing the text file.
    SourceBook.Close False

 

Quando colava a última parte não estava deslocando as células para baixo, corrigi usando o OffSet.

 

Se optar pela exclusão da linha 7 pode fazer numa única passagem usando:

Rows(7).Delete

 

[ ]s

 

Answer 4

Adilson Soledade wrote:

Funciona se vc substituir as últimas linhas por:

 

Adilson,

 

A quais últimas linhas você se refere?

 

 

Sds

Jerson

Answer 5

Sorry,

Realmente não ficou claro.

Segue abaixo destacadas em vermelho no código.

 

Code Snippet

Sub ImportTextFile()

    Dim DestBook As Workbook, SourceBook As Workbook
    Dim DestCell As Range
    Dim RetVal As Boolean

    ' Turn off screen updating.
    Application.ScreenUpdating = False

    ' Set object variables for the active book and active cell.
    Set DestBook = ActiveWorkbook
    Range("A5").Activate
    Set DestCell = ActiveCell
   
    ' Show the Open dialog box.
    RetVal = Application.Dialogs(xlDialogOpen).Show("*.xls")

    ' If Retval is false (Open dialog canceled), exit the procedure.
    If RetVal = False Then Exit Sub

    ' Set an object variable for the workbook containing the text file.
    Set SourceBook = ActiveWorkbook

    ' Copy the contents of the first six lines of the sheet containing the text file.
   
    'Last filled column in the SourceBook file
    LastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
   
    'Last filled row in the SourceBook file
    LastLine = Cells(Rows.Count, 1).End(xlUp).Row
   
    'Copy the range from the cell A2 to last column sixth line
    Range(Cells(1, 2), Cells(6, LastColumn)).Copy
   
    ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.PasteSpecial Paste:=xlValues
   
    ' Copy the contents from the eighth line to the last line of the last column
    SourceBook.Activate
    Range(Cells(8, 2), Cells(LastLine, LastColumn)).Copy
   
   ' Activate the destination workbook and paste special the values
    ' from the text file.
    DestBook.Activate
    DestCell.Offset(6, 0).PasteSpecial Paste:=xlValues

    ' Close the book containing the text file.
    SourceBook.Close False

End Sub

 

 

[]s

Answer 6

Adilson Soledade wrote:

Sorry, Realmente não ficou claro. Segue abaixo destacadas em vermelho no código. []s

 

Adilson,

 

Agora está copiando as linhas 1 a 7 duas vezes (subsequente) + a linha 8, após a segunda vez.

 

Eu já resolvi o meu problema, conforme te informei anteriormente, portanto, fica a teu critério chegar um código que funcione.

 

 

Um grande abraço.

 

Jerson 

 

Answer 7

Beleza, meu caro.

Fecha então o tópico que vou descobrir o que está falhando para referências futuras.

[ ]s