Импорт из множества txt файла в таблицу

Автор psydo.ether, 25.03.2012, 19:27

« назад - далее »

psydo.ether

Добрый Вечер!
Прошу помощи так как не разбираюсь в макросах вообще.
Суть проблемы.
Есть множество txt файлов с именами xxxxxx.txt .... порядка 1000 штук. Имена самые разнообразные но числовые. ( что то типо 123654.txt и 000345.txt итд). Содержимое файлов простой текст.
Вот требуеться их все обьеденить в таблицу из 2х колонок.
В первой колонке должно быть имя файла без расширения.
(Так Чтобы строки шли не по порядку а по дате создания оригинальных файлов.
(к примеру из 3х файлов первым в таблицу будет внесён тот что создан раньше, затем следующий по дате итд ) Если конечно такое возможно!
Если нет то хотябы по числовому возрастанию или убыванию в имени файла.)
Во второй колонке текстовое Содержимое файла но помещенное в одну ячейку. Без разбивки на строки ( весь текст в одной ячейке).
Я вообще не смыслю в скриптах excel ... Помогите пожалуйсто!


GWolf

Добрый день!

Код не мой, я его лишь причесал под поставленную задачу:
Sub DownloadFileList()
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, PathToFolder$, MaskSearch$, DepthSearch%
    Dim TextLine As String

    PathToFolder$ = "\\Energy2\pole\Komplekt_Versija\KV_Narabotki\TXT_nabor"    ' - путь к папке
    MaskSearch$ = ".txt"    ' - маска файлов
    DepthSearch% = 0    ' глубина поиска
    If DepthSearch% = 0 Then DepthSearch% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(PathToFolder$, MaskSearch$, DepthSearch%)

    Application.ScreenUpdating = False    ' отключаем обновление экрана

    k = 2
    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        FileNumber = i
        PathToFile = coll(i)
        NameFile = Dir(PathToFile)
        DateCreate = FileDateTime(PathToFile)
        FileSize = FileLen(PathToFile)
       
        Open PathToFile For Input As #1
        Do While Not EOF(1)    ' Loop until end of file.
            Line Input #1, TextLine    ' Read line into variable.
        Loop
        Close #1

        ' выводим на лист очередную строку
'        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(FileNumber, NameFile, PathToFile, DateCreate, FileSize)

        With ThisWorkbook.ActiveSheet
            With .Cells(i + k, 1)
                .NumberFormat = "@"
                .Value = CStr(Replace(NameFile, MaskSearch$, ""))
            End With
            With .Cells(i + k, 2)
                .NumberFormat = "dd/mm/yyyy hh:mm"
                .Value = DateCreate
            End With
            With .Cells(i + k, 3)
                .NumberFormat = "@"
                .Value = TextLine
            End With
        End With
       
        TextLine = ""
        ' если нужна гиперссылка на файл во втором столбце
        'ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), PathToFile, "", _
                                   "Открыть файл" & vbNewLine & NameFile

        DoEvents    ' временно передаём управление ОС
    Next
End Sub

' ===================== код функции ===========================
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep    ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function


На скрепке в виде книги Excel
Непременным условием успешной работы кода является размещение .txt - файлов в папке созданной под именем "TXT_nabor", в папке, куда будет размещен файл sborka.xls
Пока программа не умеет располагать файлы по мере создания.
Путей к вершине - множество. Этот один из многих!

shanemac51a


ПОЧТИ АНАЛОГ
Sub ARXIV_TXT_120326_1703()
'ОТКОРРЕКТИРУЙТЕ ПАБОЧИЙ КАТАЛОГ ДЛЯ XLS(C:\RAB\)
'------------------------------------TXT(C:\RAB\)
'МАКСИМАЛЬНЫЙ РАЗМЕР ТХТ(10000)
'

Dim S1, S2, SS, SBIB
Dim J1, J2
Dim ws As Worksheet
Excel.Workbooks.Add
Excel.ActiveWorkbook.SaveAs "C:\RAB\" & Format(Now, "YYYY-MM-DD HH-MM") & ".XLS"

Set ws = Excel.ActiveWorkbook.Worksheets(1)
'As Action
J1 = 0
SBIB = "C:\RAB\"
S1 = Dir(SBIB & "*.TXT")
Do While Len(S1) > 0
SS = ""
J1 = J1 + 1
Open SBIB & S1 For Input As #1
S2 = ""
Do While EOF(1) = False
Line Input #1, S2
If Len(SS) > 10000 Or Len(SS) > 10000 Then
SS = "ОЧЕНЬ БОЛЬШОЙ"
Exit Do
End If
SS = SS & S2
S2 = Chr(13) & Chr(10)
Loop
Close #1
ws.Cells(J1, 1) = SBIB & S1
ws.Cells(J1, 2) = SS
ws.Cells(J1, 3) = Len(SS)

S1 = Dir

Loop
Debug.Print Now
MsgBox "СФОРМИРОВАН " & ActiveWorkbook.Name
End Sub



psydo.ether

Спасибо огромное =) Все что надо у меня получилось. Но вот в первом скрипте инфа из файлов не вставляеться в ячейку а вставляеться просто ... Тоесть построчно. Тему можно закрывать !

sanchoss

#4
можете дописать, чтобы искало в подпапках, глубиной 3-5 ?
спасибо.

sanchoss

#5
если в txt файле есть несколько абзацев, в excel вставляет только последний.
можно сделать чтобы все абзацы вставило?

sanchoss

Из двух кодов сделал один:

    '=====================
    'https://forum.msexcel.ru/empty-t7606.0.html
    '
    'Есть множество txt файлов с именами xxxxxx.txt .... порядка 1000 штук. _
     Имена самые разнообразные но числовые. ( что то типо 123654.txt и _
     000345.txt итд). Содержимое файлов простой текст.
    'Вот требуеться их все обьеденить в таблицу из 2х колонок.
    'В первой колонке должно быть имя файла без расширения.
    '(Так Чтобы строки шли не по порядку а по дате создания оригинальных файлов.
    '(к примеру из 3х файлов первым в таблицу будет внесён тот что создан раньше, _
     затем следующий по дате итд ) Если конечно такое возможно!
    'Если нет то хотябы по числовому возрастанию или убыванию в имени файла.)
    'Во второй колонке текстовое Содержимое файла но помещенное в одну ячейку. _
     Без разбивки на строки ( весь текст в одной ячейке).
    '=====================

Sub af_Sbor_Щелкнуть()
    'Реакция на щелчок по кнопке "Собрать" листа "_" книги "sborka.xls"
   
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, PathToFolder$, MaskSearch$, DepthSearch%
    Dim TextLine As String
   
    PathToFolder$ = ThisWorkbook.Path & "\..\..\..\_Photo\844"    ' - путь к папке
    MaskSearch$ = ".txt"    ' - маска файлов
    DepthSearch% = 3    ' глубина поиска
    If DepthSearch% = 0 Then DepthSearch% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(PathToFolder$, MaskSearch$, DepthSearch%)

    Application.ScreenUpdating = False    ' отключаем обновление экрана

    k = 2
    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        FileNumber = i
        PathToFile = coll(i)
        NameFile = Dir(PathToFile)
        DateCreate = FileDateTime(PathToFile)
        FileSize = FileLen(PathToFile)
        PathToDir = Right(Left(PathToFile, Len(PathToFile) - Len(NameFile) - 1), 9)

        Open PathToFile For Input As #1
        TextLine2 = ""
        Do Until EOF(1)    ' Loop until end of file.
            Line Input #1, TextLine2    ' Read line into variable.
        Debug.Print TextLine ' Print to the Immediate window.
        If Len(TextLine) > 10000 Or Len(TextLine) > 10000 Then ' довжина стрічок
        TextLine = "ОЧЕНЬ БОЛЬШОЙ"
        Exit Do
        End If
        TextLine = TextLine & TextLine2
        TextLine2 = Chr(13) & Chr(10)
        Loop
        Close #1

        ' выводим на лист очередную строку
'        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(FileNumber, NameFile, PathToFile, DateCreate, FileSize)

        With ThisWorkbook.ActiveSheet
            With .Cells(i + k, 5)
                .NumberFormat = "@"
                .Value = PathToDir
            End With
            With .Cells(i + k, 6)
                .NumberFormat = "@"
                .Value = CStr(Replace(NameFile, MaskSearch$, ""))
            End With
            With .Cells(i + k, 7)
                .NumberFormat = "dd/mm/yyyy hh:mm"
                .Value = DateCreate
            End With
            With .Cells(i + k, 8)
                .NumberFormat = "@"
                .Value = TextLine
            End With
        End With
       
        TextLine = ""
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("h" & Rows.Count).End(xlUp), PathToFile, "", _
                                   "Открыть файл" & vbNewLine & NameFile

        DoEvents    ' временно передаём управление ОС
    Next
End Sub

' ===================== код функции ===========================
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep    ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function


текст txt:
Абзац1 текст текст.
Абзац2 текст текст.
Абзац3 текст текст.

вставляет в excel:
Абзац1 текст текст.Абзац2 текст текст.Абзац3 текст текст.

В excel вставляет последовательно абзац за абзацем без пробелов.
Нужно абзац под абзацом, так как в txt файле.

sanchoss

Реши перенос абзацев


Attribute VB_Name = "kod_Sborka"
    '=====================
    'https://forum.msexcel.ru/empty-t7606.0.html
    '
    'Есть множество txt файлов с именами xxxxxx.txt .... порядка 1000 штук. _
     Имена самые разнообразные но числовые. ( что то типо 123654.txt и _
     000345.txt итд). Содержимое файлов простой текст.
    'Вот требуеться их все обьеденить в таблицу из 2х колонок.
    'В первой колонке должно быть имя файла без расширения.
    '(Так Чтобы строки шли не по порядку а по дате создания оригинальных файлов.
    '(к примеру из 3х файлов первым в таблицу будет внесён тот что создан раньше, _
     затем следующий по дате итд ) Если конечно такое возможно!
    'Если нет то хотябы по числовому возрастанию или убыванию в имени файла.)
    'Во второй колонке текстовое Содержимое файла но помещенное в одну ячейку. _
     Без разбивки на строки ( весь текст в одной ячейке).
    '=====================

Sub af_Sbor_Щелкнуть()
    'Реакция на щелчок по кнопке "Собрать" листа "_" книги "sborka.xls"
   
    ' Ищем файлы в заданной папке по заданной маске,
    ' и выводим на лист список их параметров.
    ' Просматриваются папки с заданной глубиной вложения.

    Dim coll As Collection, PathToFolder$, MaskSearch$, DepthSearch%
    Dim TextLine As String
       
    PathToFolder$ = ThisWorkbook.Path & "\..\..\..\_Photo\844"    ' - путь к папке
    MaskSearch$ = ".txt"    ' - маска файлов
    DepthSearch% = 3    ' глубина поиска
    If DepthSearch% = 0 Then DepthSearch% = 999    ' без ограничения по глубине

    ' считываем в колекцию coll нужные имена файлов
    Set coll = FilenamesCollection(PathToFolder$, MaskSearch$, DepthSearch%)

    Application.ScreenUpdating = False    ' отключаем обновление экрана

    k = 2
    ' выводим результаты (список файлов, и их характеристик) на лист
    For i = 1 To coll.Count    ' перебираем все элементы коллекции, содержащей пути к файлам

        FileNumber = i
        PathToFile = coll(i)
        NameFile = Dir(PathToFile)
        DateCreate = FileDateTime(PathToFile)
        FileSize = FileLen(PathToFile)
        PathToDir = Right(Left(PathToFile, Len(PathToFile) - Len(NameFile) - 1), 9)

        Open PathToFile For Input As #1
'        TextLine2 = ""
        Do Until EOF(1)    ' Loop until end of file.
            Line Input #1, TextLine2     ' Read line into variable.
        Debug.Print TextLine ' Print to the Immediate window.

        TextLine = TextLine & vbCrLf & TextLine2
'        TextLine2 = Chr(13) & Chr(10)
        Loop
        Close #1

        ' выводим на лист очередную строку
'        Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 5).Value = _
        Array(FileNumber, NameFile, PathToFile, DateCreate, FileSize)

        With ThisWorkbook.ActiveSheet
            With .Cells(i + k, 5)
                .NumberFormat = "@"
                .Value = PathToDir
            End With
            With .Cells(i + k, 6)
                .NumberFormat = "@"
                .Value = CStr(Replace(NameFile, MaskSearch$, ""))
            End With
            With .Cells(i + k, 7)
                .NumberFormat = "dd/mm/yyyy hh:mm"
                .Value = DateCreate
            End With
            With .Cells(i + k, 8)
                .NumberFormat = "@"
                .Value = TextLine
            End With
        End With
       
        TextLine = ""
        ' если нужна гиперссылка на файл во втором столбце
        ActiveSheet.Hyperlinks.Add Range("h" & Rows.Count).End(xlUp), PathToFile, "", _
                                   "Открыть файл" & vbNewLine & NameFile

        DoEvents    ' временно передаём управление ОС
    Next
End Sub

' ===================== код функции ===========================
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep    ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function