Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Частичный импорт данных из txt файлов в Excel
 
#1
26.10.2021 08:31:13
Есть вот такой макрос, который импортирует всё содержимое всех выбранных файлов в один столбец в excel.
Код
Option Explicit

Sub ImportTXTFiles()
    Dim importrow As Long
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim qt As QueryTable
    Dim txtfilesToOpen As Variant, txtfile As Variant

    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")

    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="Text Files to Open")

    With ActiveSheet

        For Each txtfile In txtfilesToOpen

            importrow = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
            
            With .QueryTables.Add(Connection:="TEXT;" & txtfile, _
              Destination:=.Cells(importrow, 1))
                .TextFileParseType = xlDelimited
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = False
                .TextFileSpaceDelimiter = False
                .TextFileOtherDelimiter = "|"
                .Refresh BackgroundQuery:=False
            End With


        Next txtfile

        For Each qt In .QueryTables
            qt.Delete
        Next qt

    End With

    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"

    Set fso = Nothing
End Sub

Возможно ли подкорректировать макрос так, что бы он импортировал только определённую часть из txt файла?

На данном скриншоте пример txt файла. Количество строк до vst_start рандомное, после vst_end (в конце файла) так же рандомное. Начиная с vst_start и до vst_end количество строк так же рандомное.
Скрытый текст

А вот такой результат должен быть в excel:
Скрытый текст
 
 
 
 
#2
26.10.2021 09:15:46
Подкорректировать данный макрос, вряд ли, а вот написать новый скорее всего придется
Или вернее переписать основную часть.
Здесь пару вариантов
построчно перебрать каждый файл
либо сначала разбить данные на массивы по vst_start
а затем уже элементы полученного массива по vst_end
затем проверить сколько элементов в массиве и если 2
то первый элемент массива выводим на лист ну и т.д
Спасибо
 
 
 
#3
26.10.2021 09:32:55
Код
Option Explicit
 
Const vst_start = "vst_start"
Const vst_end = "vst_end"
 
Sub ImportTXTFiles()
    Dim importrow As Long
    Dim fso As Object
    Dim xlsheet As Worksheet
    Dim txtfilesToOpen As Variant, txtfile As Variant
 
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
 
    txtfilesToOpen = Application.GetOpenFilename _
                 (FileFilter:="Text Files (*.txt), *.txt", _
                  MultiSelect:=True, Title:="Text Files to Open")
 
    With ActiveSheet
        Dim txt As String
        Dim arr As Variant
        Dim brr As Variant
        Dim vv As Variant
        For Each txtfile In txtfilesToOpen
            
            With fso.OpenTextFile(txtfile, 1, False)
                txt = .ReadAll
                .Close
            End With
            
            arr = Split(txt, vst_start)
            
            If Not IsEmpty(arr) Then
                For Each vv In arr
                    If InStr(vv, vst_end) > 0 Then
                        txt = Split(vv, vst_end)(0)
                        txt = Join(Array(vst_start, txt, vst_end), "")
                        brr = Split(txt, vbCrLf)
                        
                        importrow = 1 + .Cells(.Rows.Count, 1).End(xlUp).Row
                        .Cells(importrow, 1).Resize(UBound(brr) + 1, 1) = Application.Transpose(brr)
                    End If
                Next
            End If
        Next txtfile
 
    End With
 
    Application.ScreenUpdating = True
    MsgBox "Successfully imported text files!", vbInformation, "SUCCESSFUL IMPORT"
 
    Set fso = Nothing
End Sub
 
 
 
#4
26.10.2021 11:21:29
МатросНаЗебре, Благодарю! Всё идеально.
 
 
 
Страницы: 1
Наверх