обьединение одинаковых файлов ексель

[Alex47]

Добрый день, а быть может и вечер!Прошу простить если не в тему.Есть более 100 одинаковых екселевских документов, задача нужно их всех соеденить в один и на один лист.В программировании навыков нет,так как больше занимался обслуживанием и наладкой ЛВС.Поисковиком пользоваться умею и искал ответ на свой вопрос.Зарание спасибо за помощь оказанную!Прикрепить файл не получилось

[R Dmitry]

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

Добрый день, а быть может и вечер!Прошу простить если не в тему.Есть более 100 одинаковых екселевских документов, задача нужно их всех соеденить в один и на один лист.В программировании навыков нет,так как больше занимался обслуживанием и наладкой ЛВС.Поисковиком пользоваться умею и искал ответ на свой вопрос.Зарание спасибо за помощь оказанную!Прикрепить файл не получилось

http://www.planetaexcel.ru/plex.php

[alex77755]

Поисковиком пользоваться умею

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

[Alex47]

Спасибо добрые люди, но зачем сразу обзывать - я искал и данные варианты мне не подходят, в связи с этим и был задан вопрос.Если можете то помогите, а хамом я и сам могу быть.В чужем глазу соринку видим мы, хотя в своем бревно не видим мы.

[SAS888]

Прикрепить файл не получилось

Смогу помочь только при наличии исходных файлов (не обязательно 100 штук и не обязательно полных) и файла примера того, что требуется получить.
Так что... Постарайтесь все-таки прикрепить файл. Если информация конфиденциальная - обращайтесь через "личку".

[kuklp]

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

Спасибо добрые люди, но зачем сразу обзывать - я искал и данные варианты мне не подходят, в связи с этим и был задан вопрос.Если можете то помогите, а хамом я и сам могу быть.В чужем глазу соринку видим мы, хотя в своем бревно не видим мы.

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

[Alex47]

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

[EducatedFool]

Выложить не получается,пишет ошибка присоединения файла

Если бы почитали правила раздела - то обнаружили бы, что файлы надо прикреплять запакованными в архив

[Hugo121]

Вот такой есть известный код (думаю, не грех повторить, благо название темы соответствует):

Константа blInsertName (true или false) определяет, надо ли вставлять строку с заголовком перед данными.

Sub FiziK()
 
Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = True  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
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

[Alex47]

Спасибо, буду пробывать.В отношении как выкладывать файлы прочитал изначально,пробывал и rar и zip - результат отрецательный.