vba循环遍历文件夹中的文件，并在满足/不满足多个条件时复制名称

我想在一个文件夹中循环并复制EXCEL文件的所有名称，这些文件不包含A6中的string1、B6中的string2、C6中的string3、D6中的string4。注：所有条件均应为真，并声明为真。 应测试的电池位于表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

---

原始代码来自以下链接：

首先，我更改了检索文件的代码，因为它收集所有文件，而不管它是否是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

然后，我使用以下函数检索文件的内容，您可以在resp中找到这些文件

---

我使用了您现有的代码，刚刚在循环中添加了一个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
'...

---

你试过什么吗？这些条件是And还是or？你说的是哪张纸，总是第一张？是的，我尝试了不同的东西，最新的是“文件夹中每个文件”的注释部分，如果checknameExistensFolder.Files，那么它不起作用，所以我删除了它。条件是和，应该是第3页名为ProjectOperation，然后我建议编辑文章并添加附加信息。你怎么知道总是第三张？好的，我会的。这是一个很好的问题-要么是第3页，要么是名为ProjectOperation的页。首先，非常感谢您的回答！：但是我无法让代码正常工作。可能是我没有正确解释我的问题，或者只是不理解代码。我将在一个示例中解释：我有3个名为e1、e2和e3的excel文档。e1和e2相同，它们在A6、B6、C6、D6中具有相同的文本，但e3在单元格D6中具有不同的文本。因此，我希望e3的workbookname列在我的VBA excel中，因为它不符合其他的条件。谢谢你抽出时间！：我建议编辑你的帖子，以使你的问题更清楚，因为根据你的评论，这似乎与我所理解的不同。无论如何，我认为，您也可以使用我的部分代码来做您想做的事情，因为SelectFiles为您提供了所有excel文件的集合，GetValue为您提供了excel文件中某些单元格的值。如果你根据你的需要把它组合起来，它应该会起作用。你只需要调整测试列表，这应该不会那么困难。

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

'...
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
'...