Склеивание таблиц из разных файлов в один

[zenner]

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

гдето так.

Private Sub CommandButton1_Click()
Dim M_File As String
M_File = "C:\Activare201105030511.xls"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim s
Set txt = oFSO.OpenTextFile(M_File, 1, True)
  s = txt.ReadLine
    i = 2
Do While Not txt.AtEndOfLine

    s = txt.ReadLine
     dd = Split(s, Chr(9), -1)
     For n = 0 To UBound(dd)
Cells(i, n + 1) = dd(n)
      Next
 i = i + 1
Loop
txt.Close
Set txt = Nothing
Set oFSO = Nothing
End Sub

Клей закончился

А Вы не могли бы выложить готовый файл с данным макросом а то у меня не работает? Спасибо!

[doober]

Все прекрасно работает.
Я же писал,клей закончился

[zenner]

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

Все прекрасно работает.
Я же писал,клей закончился

Данный макрос обрабатывает только один файл а мне нужно чтобы он обработал все файлы которые есть в папке.

[doober]

Поиск уже не рулит
Получение списка файлов в папке и подпапках средствами VBA

Получаете список файлов и открываете по порядку

[zenner]

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

Поиск уже не рулит
Получение списка файлов в папке и подпапках средствами VBA

Получаете список файлов и открываете по порядку

Так а вместо M_File = "C:\Activare201105030511.xls" нельзя написать что то вроде M_File = "C:\.xls"
или M_Path = "C:\"

[zenner]

Уважаемые Форумчане, очень прошу Вашей помощи так как сам не могу справится с этой задачей а для работы очень нужно. Помогите пожалуйста с этим макросом который соединит все содержимое многих файлов в один. Вот примеры этих файлов: dec.rar

Структура у всех файлов одинаковая!!! Макрос просто должен скопировать все содержимое всех файлов которые будут в папке в один итоговый файл.
Спасибо!

[zenner]

Вот нашел на сайте http://forum.ixbt.com/topic.cgi?id=23:34091 макрос который мне нужен но есть пару вопросов.
Подскажите пожалуйста что изменить чтобы не портился формат даты и времени как в оригиналах(03.05.2011 17:11) и чтобы не повторялась первая строка всех файлов а только одна из первого (так как они во всех файлах одинаковые). Спасибо!

Sub FiziK()
 
Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = False  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    For Each shSrc In wbSrc.Worksheets
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            shSrc.UsedRange.Copy clTarget
        End If
    Next
    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub