VBA - 仅当满足多个条件时才循环浏览文件夹中的文件

Question

我目前正在使用一段代码循环浏览文件夹中的文件，并将每个文件中的某些单元格复制到主列表中。每周都会将许多文件添加到该文件夹​​中。主列表中的一列包括以前循环文件的文件名。该代码仅循环遍历未包含在文件名列表中的文件，因此之前也没有被循环过。

我想扩展它并添加两个调整。我希望代码复制额外的数据位，但是这次它不仅仅是一个单元格（特别是A20:H33）。当我尝试更改代码以复制一个范围时，代码停止工作。

此外，我只想从具有特定文件名结尾的文件（例如“xxxxFAM”）以及尚未循环的文件中复制数据 - 此文件名结尾将在单元格中选择在数据被复制到的工作表上。 （例如单元格 P3）。关于我如何做到这一点的任何想法？

这是我目前正在使用的代码，它是在堆栈溢出成员的帮助下开发的！请注意，我的大部分工作都是反复试验，请参阅下面的尝试。

Option Explicit

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 6) As Variant

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

ws.Range("A4:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

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) = .Range("A13").Value
            varTemp(2) = .Range("H8").Value
            varTemp(3) = .Range("H9").Value
            varTemp(4) = .Range("H36").Value
            varTemp(5) = .Range("H37").Value
            varTemp(6) = strFile
        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 1), ws.Cells(r, 6)).Formula = varTemp
    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("F:F").Find(strFile)

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

End Function

这是尝试 1，我只是将其中一个 vartemp 更改为一个范围 - 不出所料，这不起作用（没有错误 - 范围根本没有被复制）

Sub CopyFromFolderExample()

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

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

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
            varTemp(6) = .Range("A20:A33").Value

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

这是使用 selection.copy 和 selection.paste 的尝试 2（“对象不支持此属性或方法”错误，未找到解决方法：

Sub CopyFromFolderExample()

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

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

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

.Range("A20:H33").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

ws.Activate

If ws.Range("A1") = "" Then
ws.Range("A1").Select
Selection.Paste
Else
Selection.End(xlDown).Offset(6, 0).Select
Selection.Paste
End If

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

这是尝试 3，使用合并到主代码中的修改子：（范围和单元格都被复制，但是我无法将其合并到主代码中，因此只有在条件满足时才复制范围遇到）：

Sub CopyFromFolderExample()

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

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

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
            'varTemp(6) = .Range("A20:A33").Value

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "DELIVERY NOTE"
xRgStr = "A20:H33"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
    If .Show = -1 Then
        xSelItem = .SelectedItems.Item(1)
        Set xWorkBook = ThisWorkbook
        Set xSheet = xWorkBook.Sheets("DN Compile")
        If xSheet Is Nothing Then

xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets ---> 
--->(xWorkBook.Worksheets.Count)).Name = "DN Compile"
            Set xSheet = xWorkBook.Sheets("DN Compile")
        End If
        xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
        If xFileName = "" Then Exit Sub
        Do Until xFileName = ""
           Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
            Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
            xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
            xFileName = Dir()
            xBook.Close
        Loop
    End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True

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

Answer 1

我在将范围复制到数组时遇到了类似的问题。修复它的是使用 .Value2 而不是 .Value。也许值得尝试一下。