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，我只是将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

Answer 1

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

VBA-仅在满足多个条件的情况下循环浏览文件夹中的文件

1 个答案: