VBA список excel файлов в папке?

У меня есть каталог на диске, как так:VBA список excel файлов в папке?

G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017

В пределах этого режиссера, у меня есть ряд папок на неделю, как так:

KW1 
KW2 
KW3 
ETC.

Далее, внутри каждой недельная папка У меня есть список папок поставщика:

G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW1

Среднее содержание каждой папки поставщика выглядит так:

Для справочных целей, я только о файлах первенствовать в каждой из этих папок поставщиков.

У меня есть таблица так:

Обратите внимание на каталог файлов в рабочей книге, указывая на:

G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW1

Это должно выглядеть через каждой папке поставщика в этом каталоге и перечислить все файлы excel и адрес электронной почты, содержащийся в ячейке c15, в каждом из этих файлов.

Он не перечисляет адрес электронной почты из каждого файла.

Я получаю эту ошибку:

На этой линии:

values(r, 1) = ExecuteExcel4Macro(arg)

Иногда этот код работает, если я типа в другой каталог и указать это WK 9 или 8. Но папки визуально одинаковы, все они содержат файлы pdf и excel.

Вот мой код:

Sub SO() 
    If Range("I8").Value = "" Then 
    Exit Sub 
    Else 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    '//Set your file path 

    Dim parentFolder As String 

    parentFolder = Range("I8").Value '// change as required, keep trailing slash 

    If Dir(parentFolder) = "" Then 

    parentFolder = Range("I8").Value & "\" '// change as required, keep trailing slash 

    Else 

    parentFolder = Range("I8").Value 

    End If 

    '//Fetch Results 

    Dim results As String 

    results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.xls*"" /S /B /A:-D").StdOut.ReadAll 

    Debug.Print results 
    'On Error GoTo errHandler2 
    '// uncomment to dump results into column A of spreadsheet instead: 
    Range("G17").Resize(UBound(Split(results, vbCrLf)), 1).Value = WorksheetFunction.Transpose(Split(results, vbCrLf)) 
    Range("AD17").Resize(UBound(Split(results, vbCrLf)), 1).Value = "Remove" 
    Range("V17").Resize(UBound(Split(results, vbCrLf)), 1).Value = " " 
    '//----------------------------------------------------------------- 
    '// uncomment to filter certain files from results. 
    '// Const filterType As String = "*.exe" 
    '// Dim filterResults As String 
    '// 
    '// filterResults = Join(Filter(Split(results, vbCrLf), filterType), vbCrLf) 
    '// 
    '// Debug.Print filterResults 
    'On Error GoTo errHandler 
    Dim app As New Excel.Application 
    app.Visible = False 'Visible is False by default, so this isn't necessary 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 


    '//Email copy code 


    Dim startCell As Range, fileRng As Range 
    Dim files As Variant, values() As Variant, values2() As Variant 
    Dim path As String, file As String, arg As String 
    Dim r As Long, i As Long 

    'Acquire the names of your files 
    With ThisWorkbook.Worksheets(1) 'amend to your sheet name 
     Set startCell = .Range("G17") 'amend to start cell of file names 
     Set fileRng = .Range(startCell, .Cells(.Rows.Count, startCell.Column).End(xlUp)) 
    End With 
    files = fileRng.Value2 

    'Size your output array 
    ReDim values(1 To UBound(files, 1), 1 To 1) 


    'Populate output array with values from workbooks 
    For r = 1 To UBound(files, 1) 
     'Create argument to read workbook value 
     i = InStrRev(files(r, 1), "\") 
     path = Left(files(r, 1), i) 
     file = Right(files(r, 1), Len(files(r, 1)) - i) 
     arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
     'Acquire the value 



     values(r, 1) = ExecuteExcel4Macro(arg) 





    Next 


    'Write values to sheet 
    fileRng.Offset(, 16).Value = values 



    '// end email copy code 

    errHandler: 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 



    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 

    End If 
    Exit Sub 

    errHandler2: 
    MsgBox "Could not locate folder directory." 
    Exit Sub 

    End Sub

Пожалуйста, может кто-то показать мне, где я буду неправильно?

EDIT:

Я просто понял это. Это связано с тем, что в папке или имени файла есть апостроф.

И что-то делать с этой частью коды, где он получает имя файла

'Populate output array with values from workbooks 
     For r = 1 To UBound(files, 1) 
      'Create argument to read workbook value 
      i = InStrRev(files(r, 1), "\") 
      path = Left(files(r, 1), i) 
      file = Right(files(r, 1), Len(files(r, 1)) - i) 
      arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
      'Acquire the value 



     values(r, 1) = ExecuteExcel4Macro(arg)

Есть ли способ исправить это?

EDIT2:

С кодом, предложенным @ A.S.H

Когда я отладки и печати ошибок, это выглядит следующим образом.

Нет ошибки в распечатываются

Редактировать 3

Посмотрев в ближайшем окне, я вижу следующие значения ошибок отладки печати:

EDIT 4:

С обновленной кодовой форме @ A.s.H Это единственные ошибки которые производятся в ближайшем окне:

'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\AM Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\CONF AM Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Burts Potato Crisps Ltd\Burts KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Burts Potato Crisps Ltd\CONTACT Burts Potato Crisps Ltd KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\High 5\High 5 KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\High 5\AM2 High 5 KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\PhD Nutrition\PHD KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\PhD Nutrition\AM PHD KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Meastsnacks Group\Meatsnacks KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\USN\USN KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\General Mills UK\General Mills KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\AM Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\CONF AM Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Symington's Ltd\CONF Symingtons KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Symington's Ltd\Symingtons KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Copernus\Copernus KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Dale Farm\Dale Farm KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Tayto Group Ltd\Tayto Group KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Tayto Group Ltd\CONF Tayto Group KW10.17.xlsx 

'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\AM Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Magners GB Ltd\CONF AM Magners KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Burts Potato Crisps Ltd\Burts KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Burts Potato Crisps Ltd\CONTACT Burts Potato Crisps Ltd KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\High 5\High 5 KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\High 5\AM2 High 5 KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\PhD Nutrition\PHD KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\PhD Nutrition\AM PHD KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Meastsnacks Group\Meatsnacks KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\USN\USN KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\General Mills UK\General Mills KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\AM Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Bon Bon Buddies\CONF AM Bon Bon Buddies KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Symington's Ltd\CONF Symingtons KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Symington's Ltd\Symingtons KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Copernus\Copernus KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Dale Farm\Dale Farm KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Tayto Group Ltd\Tayto Group KW10.17.xlsx 
G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW10\Tayto Group Ltd\CONF Tayto Group KW10.17.xlsx 

'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3 
'[]Sheet1'!R15C3

EDIT 5:

с кодом, представленной @dee я все еще получаю ту же ошибку. Ошибка 1004. Heres', как я использую его код:

Sub SO() 
    If Range("I8").Value = "" Then 
    Exit Sub 
    Else 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 

    '//Set your file path 

    Dim parentFolder As String 

    parentFolder = Range("I8").Value '// change as required, keep trailing slash 

    If Dir(parentFolder) = "" Then 

    parentFolder = Range("I8").Value & "\" '// change as required, keep trailing slash 

    Else 

    parentFolder = Range("I8").Value 

    End If 

    '//Fetch Results 

Dim results As String 
results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.xls*"" /S /B /A:-D").StdOut.ReadAll 

Dim files, i, r, path, file, arg, macroResult 
files = Split(Strings.Trim(results), vbCrLf) 
ReDim values(LBound(files) To UBound(files, 1), 0 To 1) 
For r = LBound(files) To UBound(files, 1) 
    If Strings.Trim(files(r)) <> "" Then 
     i = InStrRev(files(r), "\") 
     file = Replace(file, "'", "''") 
     path = Replace(path, "'", "''") 
     arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
     macroResult = ExecuteExcel4Macro(arg) 
     If Not VBA.IsError(macroResult) Then 
      values(r, 0) = macroResult 
      values(r, 1) = file 
     Else 
      values(r, 0) = "No email was found" 
     End If 
    End If 
Next 

    'Write values to sheet 
    fileRng.Offset(, 16).Value = values 



    '// end email copy code 

errHandler: 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 



    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 

    End If 
    Exit Sub 

errHandler2: 
    MsgBox "Could not locate folder directory." 
    Exit Sub 

    End Sub

Ошибка в этой строке:

macroResult = ExecuteExcel4Macro(arg)

источник

2017-01-20 user7415328

Вы пытались добавить отладочную ошибку в строку? Затем вы можете захватить значение 'arg' и скопировать его в блокнот/текстовый редактор и посмотреть, есть ли проблемы в формуле. Вы можете вставить это как формулу в Excel и посмотреть, может ли макет формулы Excel указать, где формула неверна. – MiguelH

Вам нужно добавить макрос, который вы вызываете в arg, поэтому посмотрите на это немного, чтобы помочь http://www.ashishmathur.com/tag/xlm-4-0-macro/ = GET.CELL (#, arg), похоже, будет синтаксисом, который вы будете после –

@MiguelH, пожалуйста, см. edit – user7415328

Как я уже говорил в моем comment, гораздо проще использовать Scripting.FileSystemObject перебрать папки и файлы, чем разбор вывода команды из командной строки DIR (как вы делаете в вашем вопросе) или даже с помощью встроенной функции VBA Dir.

Добавить ссылку на Microsoft выполнения сценариев (Tools ->Список использованной литературы ...).

Затем вы можете использовать следующий код:

Sub SO() 
    Dim fso As New FileSystemObject 
    Dim weekFolder As Folder 
    'replace 1 with either the name or the index of the worksheet which holds the week folder path 
    'replace B4 with the address of the cell which holds the week folder path 
    Set weekFolder = fso.GetFolder(Worksheets(1).Range("B4").Value) 

    Dim supplierFolder As Folder, fle As file 
    For Each supplierFolder In weekFolder.SubFolders 
     For Each fle In supplierFolder.files 

      'test whether this is an Excel file 
      If fle.Type Like "*Excel*" Then 

       'process the file here 

      End If 

     Next 
    Next 
End Sub

После того, как у вас есть путь к файлу, вы могли бы сделать что-то подобное тому, что вы уже делаете: открыть файл с другой (скрытый) экземпляр Excel, и прочитайте содержимое C15. Я бы держался подальше от ExecuteExcel4Macro (что действительно предназначено для running Excel v4 macros), и вместо этого прочитайте содержимое напрямую.

Однако, как представляется, в программе существует логическая ошибка. Что произойдет, если в разных подпапках больше или меньше файлов Excel, чем текущий список файлов? Чтобы справиться с этой возможностью, я бы не начинал с существующего списка в качестве основы для чтения файлов (как вы делаете — files = fileRng.Value2).

Вместо этого я бы очистил список между каждым прогоном. Затем я буду проходить через каждую из папок, затем через каждую из подпапок, затем через каждый файл в подпапке и проверять каждый файл, если он является файлом Excel или нет. Если это так, добавьте путь и адрес электронной почты в файл к Scripting.Dictionary —, который содержит пары (уникальных) ключей и (не уникальные значения). В конце поиска пути и электронные письма можно легко вставить в рабочий лист.

(NB. Существует дополнительное преимущество в использовании Словаря, поскольку вам не нужно беспокоиться о его изменении.)

Sub SO() 
    'clear the existing list here -- not implemented 
    '... 

    Dim pathsEmails As New Dictionary 
    Dim app As New Excel.Application 

    Dim fso As New FileSystemObject 
    Dim weekFolder As Folder 
    'replace 1 with either the name or the index of the worksheet which holds the week folder path 
    'replace B4 with the address of the cell which holds the week folder path 
    Set weekFolder = fso.GetFolder(Worksheets(1).Range("B4").Value) 

    Dim supplierFolder As Folder, fle As file 
    For Each supplierFolder In weekFolder.SubFolders 
     For Each fle In supplierFolder.files 

      'test whether this is an Excel file 
      If fle.Type Like "*Excel*" Then 

       'open the workbook, read and save the email, and close the workbook 
       Dim book As Workbook 
       Set book = app.Workbooks.Open(fle.path, , True) 
       pathsEmails(fle.path) = book.Worksheets("Sheet1").Range("C15").Value 
       book.Close False 

      End If 

     Next 
    Next 

    app.Quit 

    'copy the paths and emails to the worksheet 
    '(as above) replace 1 with either the name or the index of the worksheet which holds the week folder path 
    'paths are pasted in starting at cell B6, downwards 
    'emails are pasted in starting at cell C6, downwards 
    Worksheets(1).Range("B6").Resize(UBound(pathsEmails.Keys) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Keys) 
    Worksheets(1).Range("C6").Resize(UBound(pathsEmails.Items) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Items) 
End Sub

Ссылки:

VBA язык

Option Explicit оператор
Like оператор
Instr функция
InstrRev функция

FileSystemObject

FileSystemObject объект
Folder объект
SubFolders собственности и Folders коллекции
File объект

словарь

MSDN
Keys метод
Items метод

Excel объекты

Application объекта, Workbooks свойства
Workbooks сбора, Open метод, Workbook объекта
Worksheets недвижимость, Worksheets сбора, Worksheet объекта, Range свойства
Close метод
Range объект, Resize недвижимости, Value недвижимости
Transpose метод, соответствующий функции рабочего листа Excel TRANSPOSE

источник

2017-01-21 20:00:00

Этот код кажется очень медленным. Он открывает каждую рабочую книгу и спрашивает пользователя, хотят ли они сохранить изменения для каждой рабочей книги. – user7415328

Этот код также говорит, что для этой строки требуется ошибка объекта: Листы (1) .Range («B6»). Resize (UBound (dc.Keys) + 1, 1) .Value = WorksheetFunction.Transpose (dc.Keys) – user7415328

спасибо, но теперь я получаю код ошибки вне диапазона здесь: pathsEmails (fle.path) = book.Worksheets ("Sheet1"). Range ("C15") .Value – user7415328

Вы можете „двойной вверх“ апострофы в вашем file и path перед отправкой их в ExecuteExcel4Macro, то есть перед составлением аргумента arg.

file = Replace(file, "'", "''") 
path = Replace(path, "'", "''") 
arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
values(r, 1) = ExecuteExcel4Macro(arg)

Это будет работать содержат ли оригинальные именует ' или нет (ничего не будет repalced в последнем случае).

ExecuteExcel4Macro метод, как и почти все строки переводчиков при наблюдении четного числа апострофов в командной строке, будет разделить их на два и принять их как litteral символов (то есть, он не будет интерпретировать). Это называется escaping.

EDIT

Чтобы иметь явное описание формул, которые не работают, вы можете написать это, чтобы обнаружить их и распечатать их:

On Error Resume Next 
values(r, 1) = ExecuteExcel4Macro(arg) 
If Err.Number <> 0 Or IsError(values(r, 1)) Or IsEmpty(values(r, 1)) Then Debug.Print arg 
On Error Goto 0

Получение списка ошибочных формул сильно поможет выясняя проблему.

источник

2017-01-20 10:32:48

спасибо за это предложение, но я все равно получаю ту же ошибку. – user7415328

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

@ user7415328, если вы добавляете 'Debug.Print arg' перед командой' ExecuteExcel4Macro', что вы получаете? Пожалуйста, попробуйте получить ошибочный пример и вставьте его здесь. –

В вашем коде у вас есть некоторые логические ошибки, которые приводят к тому, что переменная arg содержит недопустимый путь. Вот упрощенный пример того, как он может работать. Используйте массив results, не записывая его на листе.И, наконец, проверьте значение ошибки ExecuteExcel4Macro, потому что это возвращает ошибку, когда целевая ячейка не содержит данных. В противном случае ваш код работает. НТН

Dim results As String 
results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.xls*"" /S /B /A:-D").StdOut.ReadAll 

Dim files, i, r, path, file, arg, macroResult 
files = Split(Strings.Trim(results), vbCrLf) 
ReDim values(LBound(files) To UBound(files, 1), 0 To 1) 
For r = LBound(files) To UBound(files, 1) 
    If Strings.Trim(files(r)) <> "" Then 
     i = InStrRev(files(r), "\") 
     path = Left(files(r), i) 
     file = Right(files(r), Len(files(r)) - i) 
     arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
     macroResult = ExecuteExcel4Macro(arg) 
     If Not VBA.IsError(macroResult) Then 
      values(r, 0) = macroResult 
      values(r, 1) = file 
     Else 
      values(r, 0) = "No email was found" 
     End If 
    End If 
Next

Примечание: Правильное arg значение выглядит следующим образом:

G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\2017\KW1\[AM Arla Foods UK KW1.17.xlsx]Sheet1'!R15C3.

Когда arg выглядит, например, например, '[]Sheet1'!R15C3, возникает следующая ошибка, и это сигнализирует, что у вас все еще есть ошибки в вашем коде, а переменная arg имеет недопустимые данные.

источник

2017-01-20 16:20:53 dee

спасибо за это, но мне нужно как название книги, так и электронное письмо, которое будет отображаться в отдельных колонках по листу таблицы? Могла ли эта способность быть добавлена? – user7415328

Я получаю ту же ошибку, ошибка 1004 в этой строке: macroResult = ExecuteExcel4Macro (arg) – user7415328

см. Отредактированный ответ, теперь 'values' имеет два измерения и добавлен пример проблемы с недопустимым' arg'. – dee

-1

Я думаю, что вы хотите, чтобы перечислить все файлы во всех папках и все вложенные папки. Проверьте эту ссылку.

http://www.learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/

Скачать файл; это путь. Если вы хотите увидеть VBA, это в основном так. , ,

view plaincopy to clipboardprint? 

    Sub GetFilesInFolder(SourceFolderName As String) 

    '--- For Example:Folder Name= "D:\Folder Name\" 

    Dim FSO As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder 
    Dim FileItem As Scripting.File 

     Set FSO = New Scripting.FileSystemObject 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 

     '--- This is for displaying, whereever you want can be configured 

     r = 14 
     For Each FileItem In SourceFolder.Files 
      Cells(r, 2).Formula = r - 13 
      Cells(r, 3).Formula = FileItem.Name 
      Cells(r, 4).Formula = FileItem.Path 
      Cells(r, 5).Formula = FileItem.Size 
      Cells(r, 6).Formula = FileItem.Type 
      Cells(r, 7).Formula = FileItem.DateLastModified 
      Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)" 

      r = r + 1 ' next row number 
     Next FileItem 

     Set FileItem = Nothing 
     Set SourceFolder = Nothing 
     Set FSO = Nothing 
    End Sub 

view plaincopy to clipboardprint? 

    Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean) 

    '--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No 

    Dim FSO As Scripting.FileSystemObject 
    Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder 
    Dim FileItem As Scripting.File 
    'Dim r As Long 
     Set FSO = New Scripting.FileSystemObject 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 

     '--- This is for displaying, whereever you want can be configured 

     r = 14 
     For Each FileItem In SourceFolder.Files 
      Cells(r, 2).Formula = r - 13 
      Cells(r, 3).Formula = FileItem.Name 
      Cells(r, 4).Formula = FileItem.Path 
      Cells(r, 5).Formula = FileItem.Size 
      Cells(r, 6).Formula = FileItem.Type 
      Cells(r, 7).Formula = FileItem.DateLastModified 
      Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)" 

      r = r + 1 ' next row number 
     Next FileItem 

     '--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling. 

     If Subfolders = True Then 
      For Each SubFolder In SourceFolder.Subfolders 
       ListFilesInFolder SubFolder.Path, True 
      Next SubFolder 
     End If 

     Set FileItem = Nothing 
     Set SourceFolder = Nothing 
     Set FSO = Nothing 
    End Sub

источник

2017-01-21 22:28:33 ryguy72

Это всего лишь копия связанного кода без учета вопроса. –

VBA список excel файлов в папке?

ответ

Смежные вопросы