VBA цикл по файлам в папке и копировать имена, если несколько условий выполнены / не выполнены

Question

Я хотел бы перебрать папку и скопировать все имена файлов Excel, которые не содержат «string1» в A6, «string2» в B6, «string3» в C6, «string4» в D6. Обратите внимание, что все условия должны быть истинными (оператор AND). Ячейки, которые должны быть проверены, расположены на листе 3, который называется «ProjectOperation».

Следующая копия кода помещает имена всех файлов Excel в определенную папку, однако мне сложно реализовать условия. Пожалуйста помоги.

Option Explicit

Sub SubDirList() 'Excel VBA process to loop through directories listing files
Dim sname As Variant
Dim sfil(1 To 1) As String
sfil(1) = "C:\Users\test" 'Change this path to suit.

For Each sname In sfil()
SelectFiles sname
Next sname

End Sub

Private Sub SelectFiles(sPath) 'Excel VBA to show file path name.
Dim Folder As Object
Dim file As Object
Dim fldr
Dim oFSO As Object
Dim i As Integer

'For Each file In Folder
 '       If checknameExistens(Folder.Files) Then

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder(sPath)
i = 1
For Each fldr In Folder.SubFolders
SelectFiles fldr.Path
Next fldr

For Each file In Folder.Files
'If checknameExistens(Folder.Files) Then
Range("A6536").End(xlUp)(2).Value = file
i = i + 1
Next file

Set oFSO = Nothing
End Sub

Оригинальный код по следующей ссылке: http://www.thesmallman.com/list-files-in-subdirectory/

Answer 1

Я работал с вашим существующим кодом и только что добавил оператор If в ваш цикл (а также пару объявлений новых переменных). Поскольку теперь вы работаете с двумя файлами, вам нужно правильно ссылаться на рабочую книгу и лист, когда вы ссылаетесь на диапазон.

'...
Dim wb As Workbook, ws As Worksheet

Application.ScreenUpdating = False
For Each file In Folder.Files
    Set wb = Workbooks.Open(file)
    Set ws = wb.Sheets("ProjectOperation")
    If ws.Range("A6").Value = "string1" And ws.Range("B6").Value = "string2" And _
       ws.Range("c6").Value = "string3" And ws.Range("D6").Value = "string4" Then
        ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Value = file 'workbook/sheet references may need changing
        i = i + 1
    End If
    wb.Close False
Next file
Application.ScreenUpdating = True
'...

Answer 2

Прежде всего я изменил код, который извлекает файлы, потому что он собирает все файлы независимо от того, является ли это файлом Excel или нет. Я также изменил его на функцию, которая возвращает все файлы обратно в коллекцию

Function SelectFiles(ByVal sPath As String, ByVal pattern As String) As Collection

Dim Folder As Object
Dim file As Object
Dim fldr
Dim oFSO As Object
Dim coll As New Collection

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = oFSO.GetFolder(sPath)

    For Each fldr In Folder.SubFolders
        SelectFiles fldr.path, pattern
    Next fldr

    For Each file In Folder.Files
        If file.Name Like pattern Then
            coll.Add file
        End If
    Next file

    Set SelectFiles = coll

End Function

Затем я использовал следующую функцию для извлечения содержимого файлов, которые вы можете найти здесь соотв. здесь

Private Function GetValue(path, file, sheet, ref)
'   Retrieves a value from a closed workbook
Dim arg As String
    '   Make sure the file exists
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "File Not Found"
        Exit Function
    End If
    '   Create the argument
    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
          Range(ref).Range("A1").Address(, , xlR1C1)
    '   Execute an XLM macro
    GetValue = ExecuteExcel4Macro(arg)
    If IsError(GetValue) Then GetValue = ""

End Function

И это конечный результат

Sub TestList()
Const SH_NAME = "ProjectOperation"
Dim sname As Variant
Dim coll As Collection
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim s4 As String
Dim i As Long

    sname = "...."     'Change this path to suit.

    Set coll = SelectFiles(sname, "*.xls*")

    For i = 1 To coll.Count
        s1 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "A6")
        s2 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "B6")
        s3 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "C6")
        s4 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "D6")
        If s1 = "string1" And s2 = "string2" And s3 = "string3" And s4 = "string4" Then
            Debug.Print coll.Item(i).path
        End If
    Next

End Sub