VBA循环浏览具有特定文件名的文件夹中的文件

拉斯科夫斯基

我设法将这段代码缓慢地开发成可用的东西，但还没有完全实现。我是VBA的新手，到目前为止，以下代码执行以下操作：

循环浏览文件夹中的工作簿
从每个工作簿中复制某些单元格
将这些单元格粘贴到具有按列组织的信息的行中
从每个工作簿中复制一个范围
将范围（14行数据）粘贴到每个工作簿中单个单元格形成的单行数据旁边（有效地将两半创建到工作表中-一半的每一行数据都属于某个工作簿（A：E列）），另一半则每个14行的范围都属于某个工作簿（F：M列））
仅当文件夹中的工作簿尚未循环时才执行上述所有操作（这是通过函数完成的）
- 此函数查看由先前运行该代码创建的文件名列-这意味着每个循环工作簿的文件名都记录在该代码创建的列表中，并且该代码仅从工作簿中复制尚未包含文件名的数据在列表中。

我一直在努力并需要帮助的代码的下一个开发过程是添加了另一个条件-即使代码仅查看以前未循环的文件，并且也仅查看文件名结尾一定的文件。一组未循环的工作簿。

我如何实现此目的的逻辑是像循环函数一样添加另一个函数，并修改其中的代码以查看在单元格中输入的名称的前三个字符，然后将其查找/比较为尚未循环的文件名（文件名结尾（后3个字符）始终是名称的前三个字符）。

这是主要的代码和功能：

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 5) As Variant, r1 As Long, r3 As Range

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"
strFile = Dir(strFolder & "*.xl*")

Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = strFile
            varTemp(2) = .Range("A13").Value
            varTemp(3) = .Range("H8").Value
            varTemp(4) = .Range("H9").Value
            varTemp(5) = .Range("H37").Value
            Set r3 = .Range("A20:H33")
        End With
        With ws
            r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
            r1 = .Range("F" & .Rows.Count).End(xlUp).Row + 1 'last used row in col F
            .Range(.Cells(r, 1), .Cells(r, 5)).Value = varTemp
            .Cells(r1, 6).Resize(r3.Rows.Count, r3.Columns.Count).Value = r3.Value 'transfer A20:H33
        End With
        wb.Close False
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

End Sub

Private Function Looped(strFile As String, ws As Worksheet) As Boolean

    Dim Found As Range
    Set Found = ws.Range("A:A").Find(strFile)

    If Found Is Nothing Then
        Looped = False
    Else
        Looped = True
    End If

    End Function

这是我试图通过向IF代码中添加另一条语句来尝试使用的修改后的函数-未成功：

Private Function notx(strFile As String, ws As Worksheet) As Boolean

Dim Found As Range
Set Found = strFile.Find(Left(ws.Range("P1").Value, 3))

If Found Is Nothing Then
    notx = False
Else
    notx = True
End If

End Function

阿鲁尔

您strFile是一个字符串，不能.Find在字符串中使用。尝试将notx功能更改为以下内容：

Private Function notx(strFile As String, ws As Worksheet) As Boolean

Dim Found As Integer
Found = InStr(1, strFile, Left(ws.Range("P1").Value, 3))

If Found = 0 Then
    notx = False
Else
    notx = True
End If

End Function

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。