макрос импорт txt в EXCEL

[ntrader]

Hugo121, а можно ли чтобы новосозданные книги автоматически сохранялись с именем файла, на основании которого была она создана? т.е. есть файл NVDA D.txt и сохраняется книга NVDA D.xls. или групповая обработка/сохранение сразу нескольких файлов. то что, уже открывается несколько книг, просто супер!

[Hugo121]

Можно конечно.
Путь к папке прописан теперь в этой переменной:
pathtofolder = "c:\Temp\ntrader\"
Можно сделать, чтоб путь брался по месту нахождения этого xls файла, или указывать папку в диалоге - подумайте, как удобнее, это легко добавить.
Можно и для сохранения изменить место.

Замените тот код на этот:

Sub tt()
    Const ForReading = 1
    Application.ScreenUpdating = False
    Dim FSO, WSH
    Dim TheFolder, TheFiles, AFile
    Dim pathtofolder$
    pathtofolder = "c:\Temp\ntrader\"
    Set WSH = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TheFolder = FSO.GetFolder(pathtofolder)    'Каталог с файлами
    Set TheFiles = TheFolder.Files
    For Each AFile In TheFiles
        If UCase(FSO.GetExtensionName(AFile.Path)) = "TXT" Then
            Set objTextFile = FSO.OpenTextFile(AFile, ForReading)
            strText = objTextFile.ReadAll
            objTextFile.Close
            a = Split(strText, vbNewLine)
            ReDim b(1 To UBound(a), 1 To 2)
            For i = 1 To UBound(a)
                b(i, 1) = Split(a(i), vbTab)(0)
                b(i, 2) = Split(a(i), vbTab)(14)
            Next
            Set wb = Workbooks.Add    '# открываем новую книгу Excel
            With wb.Sheets(1)
            .Cells(1, 1) = "Date"
            .Cells(1, 2) = "POCvo"
            .Cells(2, 1).Resize(UBound(b), 2) = b
            .Columns.AutoFit
            End With
            wb.SaveAs Filename:=pathtofolder & Replace(UCase(AFile.Name), ".TXT", "")
            wb.Close 0
        End If
    Next
    Application.ScreenUpdating = True
End Sub

[ntrader]

Сообщение от Hugo121

Можно сделать, чтоб путь брался по месту нахождения этого xls файла

Подскажите как это сделать

[Hugo121]

pathtofolder = ThisWorkbook.Path & "\"

Не забудьте добавить в конце слэш, иначе сгенерит файлы уровнем выше.
В общем, вполне удобный вариант - скопировали файл в паку с текстовыми файлами, открыли, запустили код - готово.

Вообще, вот чуть изменённая версия - теперь заголовки столбцов берутся из текстовых файлов.
В первой версии я их вписывал кодом, т.к. из файлов брал только данные, потому что сливал всё вместе. Так это и осталось...
Но теперь исправлено:

Sub tt()
    Const ForReading = 1
    Application.ScreenUpdating = False
    Dim FSO
    Dim TheFolder, TheFiles, AFile
    Dim pathtofolder$
    pathtofolder = ThisWorkbook.Path & "\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TheFolder = FSO.GetFolder(pathtofolder)    'Каталог с файлами
    Set TheFiles = TheFolder.Files
    For Each AFile In TheFiles
        If UCase(FSO.GetExtensionName(AFile.Path)) = "TXT" Then
            Set objTextFile = FSO.OpenTextFile(AFile, ForReading)
            strText = objTextFile.ReadAll
            objTextFile.Close
            a = Split(strText, vbNewLine)
            ReDim b(0 To UBound(a), 1 To 2)
            For i = 0 To UBound(a)
                b(i, 1) = Split(a(i), vbTab)(0)
                b(i, 2) = Split(a(i), vbTab)(14)
            Next
            Set wb = Workbooks.Add    '# открываем новую книгу Excel
            With wb.Sheets(1)
            .Cells(1, 1).Resize(UBound(b)+1, 2) = b
            .Columns.AutoFit
            End With
            wb.SaveAs Filename:=pathtofolder & Replace(UCase(AFile.Name), ".TXT", "")
            wb.Close 0
        End If
    Next
    Application.ScreenUpdating = True
End Sub

[ntrader]

и последнее, как можно удалить строки, где POCvo=0? имею в виду автоматически чтобы удалялись)

[Hugo121]

Точно последнее?
Это, как ни странно, добавить чуть сложнее было...
Эти строки не удаляются - они просто не импортируются.

Sub tt()
    Const ForReading = 1
    Application.ScreenUpdating = False
    Dim FSO
    Dim TheFolder, TheFiles, AFile
    Dim pathtofolder$
    pathtofolder = ThisWorkbook.Path & "\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TheFolder = FSO.GetFolder(pathtofolder)    'Каталог с файлами
    Set TheFiles = TheFolder.Files
    For Each AFile In TheFiles
        If UCase(FSO.GetExtensionName(AFile.Path)) = "TXT" Then
            Set objTextFile = FSO.OpenTextFile(AFile, ForReading)
            strText = objTextFile.ReadAll
            objTextFile.Close
            a = Split(strText, vbNewLine)
            ReDim b(0 To UBound(a), 1 To 2)
            Dim ii&: ii = -1
            For i = 0 To UBound(a)
                If Trim(Split(a(i), vbTab)(14)) <> "0.00" Then
                    ii = ii + 1
                    b(ii, 1) = Split(a(i), vbTab)(0)
                    b(ii, 2) = Split(a(i), vbTab)(14)
                End If
            Next
            Set wb = Workbooks.Add    '# открываем новую книгу Excel
            With wb.Sheets(1)
                .Cells(1, 1).Resize(ii + 1, 2) = b
                .Columns.AutoFit
            End With
            wb.SaveAs Filename:=pathtofolder & Replace(UCase(AFile.Name), ".TXT", "")
            wb.Close 0
        End If
    Next
    Application.ScreenUpdating = True
End Sub

В коде выше, где массивы с нуля начинал, была ошибка при выгрузке - последняя строка не выгружалась. Исправил.

[ntrader]

Да, это последнее. Точно)

[Hugo121]

Я ещё одну помарку нашёл - лишняя переменная WSH в код затесалась... убрал.
На функциональность не влияла, но непорядок...

[ntrader]

спасибо, Hugo121! если Вы из Украины, могу пополнить ваш моб. счет в знак благодарности)

[Hugo121]

Нет, не из Украины, так что только вебмани