Question

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

代码确实运行良好，并且可以复制单元格并获得令人满意的结果，但是我现在需要对其进行修改，以复制一系列数据（特别是A20:H33），并满足上述尚未循环的条件。 / p>

我尝试了以下失败：

在代码中添加另一个varTemp（如主代码所示）
添加一个可以复制范围的子项（但是我无法将其合并到代码中，因此它满足了非循环条件）
使用selection.copy和selection.paste，但是会弹出一个我无法解决的错误（“对象不支持此属性或方法”）

以下是主要代码：

    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\"

        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:H33").Value

                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("A:A").Find(strFile)

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

    End Function

这是代码段，当插入到最后vartemp下方的主代码中时，出现以下错误（“对象不支持此属性或方法”）

.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

这是我要实现的目标：

Answer 1

我认为，如果您使用Range变量而不是Variant来复制和粘贴Range(A20:AH33)，则应该可以完成工作。声明：

Dim rg as Range

然后替换此行代码：

varTemp(6) = .Range("A20:H33").Value

为此：

Set rg = .Range("A20:H33")

然后，您可以Rg.Copy粘贴到所需的任何位置。粘贴信息后，别忘了“清除”复制缓冲区：

Application.CutCopyMode = False

避免在代码中使用Selection和Activate，其原因如下：

How to avoid using Select in Excel VBA

在这里：

https://www.businessprogrammer.com/power-excel-vba-secret-avoid-using-select/

Answer 2

这应该做到。我已将您的数组重新设置为5个元素，并且范围是分别转移的。我添加了一些新变量，您可能想给它们提供更有意义的名称。

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

VBA-循环浏览文件夹中的文件，并在满足条件的情况下复制单个单元格以及一个范围

2 个答案: