Mauro Coutinho bom dia,
Muito obrigado pela ajuda.
Isso mesmo que estava precisando.`
Pra executar a tarefa precisa das duas rotinas abaixo?
Sub TxtImporter()
Dim f As String, flPath As String
Dim i As Long, j As Long
Dim ws As Worksheet
Dim wsExiste As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
flPath = ThisWorkbook.Path & Application.PathSeparator
i = ThisWorkbook.Worksheets.Count
j = Application.Workbooks.Count
'Armazena os nomes dos arquivos
f = Dir(flPath & "*.txt")
'Verificar se a aba existe antes de criar
wsExiste = Left(f, Len(f) - 4)
'Loop nos arquivos textos
Do Until f = ""
If WorksheetExists2(wsExiste) Then
'Sem existe verifica a próxima
f = Dir
'Sai quando não tiver mais arq texto
If f = "" Then Exit Sub
wsExiste = Left(f, Len(f) - 4)
Else
Workbooks.OpenText flPath & f
Workbooks(j + 1).Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i)
ThisWorkbook.Worksheets(i + 1).Name = Left(f, Len(f) - 4)
Columns("A:B").AutoFit
Workbooks(j + 1).Close SaveChanges:=False
i = i + 1
f = Dir
If f = "" Then Exit Sub
wsExiste = Left(f, Len(f) - 4)
End If
Loop
Application.DisplayAlerts = True
End Sub
'http://www.exceltip.com/files-workbook-and-worksheets-in-vba/determine-if-a-sheet-exists-in-a-workbook-using-vba-in-microsoft-excel.html
' Verifica se a aba existe antes de criar nova
Function WorksheetExists2(WorksheetName As String, Optional wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
With wb
On Error Resume Next
WorksheetExists2 = (.Sheets(WorksheetName).Name = WorksheetName)
On Error GoTo 0
End With
End Function
Sub ABRIR_COPIAR_TXT_EXCELORI()
Dim REL, NUMBER, LOCATION
Sheet1.Columns(1).ClearContents
LOCATION = 2
Open ThisWorkbook.Path & "fabiotxt1.txt" For Input As #1 ' OPEN SOURCE
Do While Not EOF(1) ' EOF(1)>> LOOP UNTIL END FILE
Input #1, REL '
Sheet1.Cells(LOCATION, 1) = REL '
LOCATION = LOCATION + 1
Loop
Close #1 ' CLOSE TXT
End Sub
Mais uma vez agradeço a sua generosidade.
Abraços.
Postado : 03/03/2016 8:20 am