У меня есть код, чтобы поместить все содержимое нескольких файлов .txt в Excel 2010, но требует некоторых изменений

Question

Можно ли как-нибудь поместить все содержимое нескольких файлов .txt (практически содержимое всех файлов .txt в одну папку) в Excel 2010? Мне нужно, чтобы одна ячейка (A1) была именем файла, а другая ячейка (A2) - всем содержимым этого файла .txt. То же самое относится и к другим .txt файлам, то есть B1-B2, C1-C2 и т. Д.

У меня есть этот код:

Sub test() 
    Dim myDir As String, fn As String, ff As Integer, txt As String 
    Dim delim As String, n As Long, b(), flg As Boolean, x 
    myDir = "c:\test" '<- change to actual folder path
    delim = vbTab '<- delimiter (assuming Tab delimited)
    Redim b(1 To Rows.Count, 1 To 1) 
    fn = Dir(myDir & "\*.txt") 
    Do While fn <> "" 
        ff = FreeFile 
        Open myDir & "\" & fn For Input As #ff 
        Do While Not EOF(ff) 
            Line Input #ff, txt 
            x = Split(txt, delim) 
            If Not flg Then 
                n = n + 1 : b(n,1) = fn 
            End If 
            If UBound(x) > 0 Then 
                n = n + 1 
                b(n,1) = x(1) 
            End If 
            flg = True 
        Loop 
        Close #ff 
        flg = False 
        fn = Dir() 
    Loop 
    ThisWorkbook.Sheets(1).Range("a1").Resize(n).Value = b 
End Sub

Но с этим кодом дело в том, что он импортирует только имена файлов, но не содержимое, и я полагаю, что это связано с тем, что в приведенном выше коде используется "delim = vbTab", и у меня нет разделителя в содержание файлов. Я хочу, чтобы все содержимое одного файла было импортировано в одну ячейку.

Answer 1

Это не тот подход, который вы используете, но я делаю это так:

Option Explicit

Sub ImportManyTXTIntoColumns()
'Summary:   From a specific folder, import TXT files 1 file per column
Dim fPath As String, fTXT As String
Dim wsTrgt As Worksheet, NC As Long

Application.ScreenUpdating = False
fPath = "C:\2010\"                      'path to files
Set wsTrgt = ThisWorkbook.Sheets.Add    'new sheet for incoming data
NC = 1                                  'first column for data

fTXT = Dir(fPath & "*.txt")             'get first filename

    Do While Len(fTXT) > 0              'process one at a time
                                        'open the file in Excel
        Workbooks.OpenText fPath & fTXT, Origin:=437
                                        'put the filename in the target column
        wsTrgt.Cells(1, NC) = ActiveSheet.Name
                                        'copy column A to new sheet
        Range("A:A").SpecialCells(xlConstants).Copy wsTrgt.Cells(2, NC)

        ActiveWorkbook.Close False      'close the source file
        NC = NC + 1                     'next column
        fTXT = Dir                      'next file
    Loop

Application.ScreenUpdating = True
End Sub

Answer 2

FileSystemObject (часть Microsoft Scripting Runtime) предлагает хорошую альтернативу для обработки файлов.

Вот краткое описание этого модуля.

Примечание:

1. Используется раннее связывание, поэтому требуется ссылка на среду выполнения сценариев. Может быть легко изменено на позднее связывание, если вы предпочитаете.
2. Для ясности я пропустил обработку ошибок и различные оптимизации скорости. Будет ли он достаточно безопасным или быстрым, будет зависеть от вашего предполагаемого использования, количества и размера файлов.

---

Sub test()
    Dim fso As FileSystemObject
    Dim txt As TextStream
    Dim pth As String
    Dim fl As File
    Dim str As String
    Dim cl As Range

    Set fso = New FileSystemObject
    pth = "C:\Test"
    Set cl = [A1]
    For Each fl In fso.GetFolder(pth).Files
        If StrComp(Right(fl.Name, 4), ".txt", vbTextCompare) = 0 Then
            Set txt = fso.OpenTextFile(fl.Path, ForReading)
            cl = fl.Name
            str = txt.ReadAll

            ' option: use this loop to split long files into multiple cells
            Do While Len(str) > 32767
                cl.Offset(0, 1) = Left(str, 32767)
                Set cl = cl.Offset(0, 1)
                str = Mid(str, 32768)
            Loop

            cl.Offset(0, 1) = str
            Set cl = cl.EntireRow.Cells(2, 1)
            txt.Close
        End If
    Next

    Set txt = Nothing
    Set fso = Nothing
End Sub