Question

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

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

2 个答案: