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

Question

我想遍历一个文件夹并复制所有不包含 A6 中的“string1”、B6 中的“string2”、C6 中的“string3”、D6 中的“string4”的 excel 文件的名称。请注意，所有条件都应为真（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

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

然后我使用以下函数检索您可以找到here resp 的文件的内容。 here

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

Answer 2

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