VBA-仅在满足多个条件的情况下循环浏览文件夹中的文件 [英] VBA - Loop through files in a folder ONLY if multiple conditions are met
问题描述
我目前正在使用一段代码来遍历文件夹中的文件，并将每个文件中的某些单元格复制到主列表中.每周都有许多文件添加到该文件夹中.主列表中的一列包括以前循环的文件的文件名.该代码仅循环通过文件名列表中未包含的文件，因此以前也没有循环过.
I am currently using a piece of code to loop through files in a folder and copy certain cells from each file into a master list. There are a number of files being added into the folder every week. One of the columns in the master list includes the filenames of previously looped files. The code only loops through files that are not included in the filename list and therefore also have not previously been looped.
我想扩展此内容并添加两个调整.我希望代码复制更多的数据，但是这次是一个范围，而不仅仅是一个单元格(特别是 A20:H33 ).当我尝试更改代码以复制范围时，代码停止工作.
I would like to extend this and add two adjustments. I would like the code to copy an extra bit of data, however this time it is a range not just a cell (A20:H33 specifically).When I try to change the code to copy a range the code stops working.
此外，我只想复制具有特定文件名结尾的文件中的数据(例如" xxxxFAM ")，也仅复制尚未循环的文件中的数据-该文件名结尾将在要复制数据的工作表上的单元格中选择.(例如，单元格P3).关于如何执行此操作的任何想法?
Furthermore, I would like to only copy data from files with a specific filename ending ("xxxxFAM" for example) as well as only from files that have not been looped yet - this filename ending would be chosen within a cell on the worksheet that the data is being copied to. (Cell P3 for example). Any ideas on how I might do this?
这是我当前正在使用的代码，它是在堆栈溢出成员的帮助下开发的！请注意，我的大部分工作都是反复试验，请参阅下面的尝试.
Here is the code that I am currently using and that has been kindly developed with the help of a stack overflow member! Please note that most of my work is trial and error, see below the attempts that have been made.
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，我只是将其中一个vartemps更改为一个范围-毫不奇怪，这不起作用(没有错误-范围仅被复制)
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
这是尝试2，使用selection.copy和selection.paste(对象不支持此属性或方法"错误，未找到解决方法:
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
推荐答案
将范围复制到数组时遇到了类似的问题.解决此问题的方法是使用.Value2而不是.Value.也许值得尝试一下.
I ran into a similar problem when copying a range into an array. What fixed it was using .Value2 instead of .Value. Might be worth a try.
这篇关于VBA-仅在满足多个条件的情况下循环浏览文件夹中的文件的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
