избавиться от лишней манипуляции

[EducatedFool]

было бы не плохо если в случае не нахождения "packinglist*", я бы мог сам указать путь к файлу (потому как файлы находятся в нескольких папках). типа ч/з кнопку "добавить"

Не совсем понял, что именно должен делать макрос.

Ну понятно, если файлов packinglist* в папке нет, то макрос выдаёт диалог выбора файла или папки. Так вот какой из диалогов нужен - диалог выбора файла - чтобы Вы могли выбрать один файл, или несколько файлов одновременно в одной папке, или всё же диалог выбора папки, чтобы макрос потом искал в выбранной Вами папке все файлы packinglist*?

Далее.

В любом случае при запуске макроса выдавать запрос выбора папки \ файла (независимо от наличия файлов packinglist* в текущей папке), или только если таковые файлы в исходной папке отсутствуют?

Желательно что бы на общий лист копировалось не сам лист (с линиями, форматами, с объединениями ячеек), а только значения

Не проблема. Сделаю в ближайшее время.

[Iskin]

Извините, что непонятно задал вопрос.
Т.е. ситуация такая. Файлы "packinglist*" я получаю в разных папках и директориях. Пример:
С:\1\ packinglist1\ packinglist1_1.xls
С:\1\ packinglist1\ packinglist1_2.xls
С:\1\ packinglist2\ packinglist2_1.xls
С:\1\ packinglist2\ packinglist2_2.xls
С:\1\ packinglistN\ packinglistN_1.xls
…
а общий файл (где будет модуль) находится С:\1\ общий.xls
при чем не исключено, что ч/з месяц путь может измениться. Если бы вы указали, как и где это можно исправить в самом модуле, было бы не плохо.

[EducatedFool]

Я правильно понимаю, что макрос должен перебирать все подкаталоги в папке "С:\1\", и если название подкаталога имеет вид "packinglistN", то обрабатывать все файлы packinglist*.xls во всех этих подкаталогах?

Или Вы хотите вручную выбрать одну из папок "С:\1\ packinglistN\", и чтобы макрос обрабатывал только файлы из этой папки?

[Iskin]

Да, вы правильно поняли. Т.е. есть общая папка, в ней еще папки. А в этих папках лежат те самые файлы из которых я должен брать данные.. Не исключено, что выбирать придеться не все файлы packinglist*.xls, хотя они лежат в одном корнево каталоге.

[EducatedFool]

Попробуйте такой вариант:

Option Compare Text

Sub Main()
    On Error Resume Next
    Application.ScreenUpdating = False: msg = ""
    'msg = "Результаты обработки:" & vbNewLine & vbNewLine
    Dim sh As Worksheet: Set sh = ThisWorkbook.Worksheets(1)
    With sh
        .Cells.ClearContents    ' очиска всех ячеек листа от прежнего содержимого
        FolderPath = GetFolderPath(, GetPath)
        If FolderPath = "" Then    ' если папка не выбрана, обрабатываем файлы из текущей папки
            msg = msg & "Обработка файлов из текущей папки" & vbNewLine & vbNewLine
            For Each File In CurrentFolderXLFileNames
                msg = msg & ProcessFile(.UsedRange.Cells(.UsedRange.Cells.Count).Offset(1).EntireRow.Cells(1), File)
            Next
        Else    ' папка выбрана. Предоставляем пользователю возможность выбрать один или несколько файлов для обработки
            msg = msg & "Обработка файлов из папки  " & FolderPath & vbNewLine & vbNewLine
            For Each File In SelectedFileNames(, FolderPath)
                msg = msg & ProcessFile(.UsedRange.Cells(.UsedRange.Cells.Count).Offset(1).EntireRow.Cells(1), File)
            Next
        End If
    End With
    sh.Cells(1).Select: Application.ScreenUpdating = True
    MsgBox msg, vbInformation, "Результаты обработки"
End Sub



Function ProcessFile(ByRef CellForInsert As Range, ByVal File As String) As String
    Dim tsh As Worksheet, tWB As Workbook
    Set tWB = Workbooks.Open(File, , True)    ' пытаемся открыть файл
    If Not tWB Is Nothing Then    ' файл открылся
        tWB.Worksheets(1).UsedRange.Copy    '  копируем ячейки
        CellForInsert.PasteSpecial xlPasteValues    ' вставляем только значения
        ProcessFile = "Файл " & tWB.Name & "  обработан успешно" & vbNewLine
        tWB.Close False    ' закрываем файл без сохранения
    Else
        ProcessFile = "Не удалось обработать файл  " & tWB.Name & vbNewLine
    End If
End Function

Function CurrentFolderXLFileNames() As Collection
    Path = GetPath: Dim coll As New Collection: res = Dir(Path)
    While res <> ""
        If LCase(res) Like "*packinglist*.xl*" And res <> ThisWorkbook.Name Then coll.Add Path & res
        res = Dir
    Wend
    Set CurrentFolderXLFileNames = coll
End Function

Function SelectedFileNames(Optional ByVal Title As String = "Виберіть файлы", Optional ByVal InitialPath As String = "c:\") As Collection
    Dim coll As New Collection: ThePath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .ButtonName = "Выбрати": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count: coll.Add .SelectedItems(i): Next
        End If
    End With
    Set SelectedFileNames = coll
End Function

Function GetPath() As String
    GetPath = ThisWorkbook.Path: PS = Application.PathSeparator
    If Not Right$(GetPath, 1) = PS Then GetPath = GetPath & PS
End Function

Function GetFolderPath(Optional ByVal Title As String = "Виберіть папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрати": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

[Iskin]

модуль отрабатывает, но для меня не много не то. При чем 1 вариант устраивал больше. К стати, теперь вставляются значения, но ексель все равно спрашивает про ссылки. Как говориться, чем сто раз услышать -лучше один раз потрогать. Для наглядности прикрепляю пример. В файле "общий файл" на листе 1-50 образец то как должно быть. Т.е. мне нужно что бы данные всех файлов "PackingList" в подконтрольных папках 1 д, 2д, и т.д. попали в "общий файл". Хочу заметить что у меня Office 2007, но нужно и для 2003.

[EducatedFool]

Option Compare Text
Public FileNames As Collection

Sub Main()
    On Error Resume Next
    Application.ScreenUpdating = False: msg = "": Application.DisplayAlerts = False
    Dim sh As Worksheet: Set sh = ThisWorkbook.ActiveSheet
    ThisWorkbook.UpdateLinks = xlUpdateLinksNever
    With sh
        .Cells.ClearContents    ' очиска всех ячеек листа от прежнего содержимого
        Set FileNames = New Collection:
        Call ReadFileNames(GetPath) ' поиск подходящих файлов во всех подпапках

        For Each File In FileNames
            msg = msg & ProcessFile(.UsedRange.Cells(.UsedRange.Cells.Count).Offset(1).EntireRow.Cells(1), File)
        Next

        '        FolderPath = GetFolderPath(, GetPath)
        '        If FolderPath = "" Then    ' если папка не выбрана, обрабатываем файлы из текущей папки
        '            msg = msg & "Обработка файлов из текущей папки" & vbNewLine & vbNewLine
        '            For Each File In CurrentFolderXLFileNames
        '                msg = msg & ProcessFile(.UsedRange.Cells(.UsedRange.Cells.Count).Offset(1).EntireRow.Cells(1), File)
        '            Next
        '        Else    ' папка выбрана. Предоставляем пользователю возможность выбрать один или несколько файлов для обработки
        '            msg = msg & "Обработка файлов из папки  " & FolderPath & vbNewLine & vbNewLine
        '            For Each File In SelectedFileNames(, FolderPath)
        '                msg = msg & ProcessFile(.UsedRange.Cells(.UsedRange.Cells.Count).Offset(1).EntireRow.Cells(1), File)
        '            Next
        '        End If
    End With
    sh.Cells(1).Select: Application.ScreenUpdating = True
    MsgBox msg, vbInformation, "Результаты обработки"
End Sub

Function ReadFileNames(ByVal FolderPath As String)
    'Dim fso As FileSystemObject, curfold As Folder, fil As File, sfol As Folder
    Set fso = CreateObject("scripting.filesystemobject")
    Set curfold = fso.GetFolder(FolderPath)

    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Name Like "*packinglist*.xl*" Then FileNames.Add fil.Path
        Next
        For Each sfol In curfold.SubFolders
            ReadFileNames sfol.Path
        Next
        Set fil = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
End Function


Function ProcessFile(ByRef CellForInsert As Range, ByVal File As String) As String
    Dim tsh As Worksheet, tWB As Workbook
    Set tWB = Workbooks.Open(File, xlUpdateLinksNever, True)    ' пытаемся открыть файл
    If Not tWB Is Nothing Then    ' файл открылся
        tWB.Worksheets(1).UsedRange.Copy     '  копируем ячейки
        CellForInsert.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone   ' вставляем только значения
        ProcessFile = "Файл   " & tWB.Name & "   обработан успешно" & vbNewLine
        tWB.Close False    ' закрываем файл без сохранения
    Else
        ProcessFile = "Не удалось обработать файл   " & tWB.Name & vbNewLine
    End If
End Function

Function CurrentFolderXLFileNames() As Collection
    Path = GetPath: Dim coll As New Collection: res = Dir(Path)
    While res <> ""
        If LCase(res) Like "*packinglist*.xl*" And res <> ThisWorkbook.Name Then coll.Add Path & res
        res = Dir
    Wend
    Set CurrentFolderXLFileNames = coll
End Function

Function SelectedFileNames(Optional ByVal Title As String = "Виберіть файлы", Optional ByVal InitialPath As String = "c:\") As Collection
    Dim coll As New Collection: ThePath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .ButtonName = "Выбрати": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count: coll.Add .SelectedItems(i): Next
        End If
    End With
    Set SelectedFileNames = coll
End Function

Function GetPath() As String
    GetPath = ThisWorkbook.Path: PS = Application.PathSeparator
    If Not Right$(GetPath, 1) = PS Then GetPath = GetPath & PS
End Function

Function GetFolderPath(Optional ByVal Title As String = "Виберіть папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрати": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

[Iskin]

пробывал на разных версиях (в 2007 и 2003) модуль зависает.

[EducatedFool]

Макрос перебирает все подпапки во всех папках, начиная с той, к которой расположен файл "общий.xls".

Если Вы поместите файл "общий.xls" на диск C, то макрос будет перебирать все папки на диске С в поисках нужных файлов.

Возможно, причина в этом.

Код проверял на 2 компьютерах. Всё работает.


Вообще, Ваше задание изменяется с каждым новым постом...

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

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

PS: Просьба ко всем: во вложении 25 укп.rar из поста #16 в файл "общий" вставьте приведённый в посте #17 код, и проверьте его работоспособность. (активировать пустой Лист2 (или любой другой) и запустить макрос Main)

Может кто подскажет, чем может быть вызвана неработоспособность этого кода...

Есть подозрение на scripting.filesystemobject и на зависание при множестве рекурсивных вызовов Function ReadFileNames, но, может быть, причина в другом?

[EducatedFool]

Попробуйте распаковать папку из вложения на рабочий стол, и в файле "Общий" нажать на желтую кнопочку.

В последнем варианте Вы должны увидеть, на каком именно действии зависает макрос.