Question

我希望在用户选择的目录中的不同子文件夹中复制/粘贴工作簿中的数据。

解释：基本上，我想自动化一个过程，从而将我从许多工作簿中复制/粘贴仪式转换为一个摘要工作簿（从中启动代码）。我已允许用户输入选择包含子文件夹的父目录。

我已经到了发生循环的阶段，但数据没有被复制和粘贴。

任何人都可以看到我的代码中的缺陷或为什么它不起作用？

非常感谢您的帮助。

Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim SubF As Scripting.Folder
Dim strFolderName As String

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = -1 Then
        strFolderName = .SelectedItems(1)
        Else
        MsgBox ("Selection Cancelled")
        Exit Sub
    End If
End With

Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder(strFolderName)
For Each SubF In FF.SubFolders
    DoOneFolder SubF
Next SubF
End Sub

Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row

 For Each F In FF.Files
    If (F.Name) Like "QC_results*" & ".xlsm" Then
        Set WBc = Workbooks.Open(F)
    ' Copy QC results range into batch summary workbook
        shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)
        WBc.Close SaveChanges:=False
        Debug.Print F.Name

    End If
Next F

For Each SubF In FF.SubFolders
    DoOneFolder SubF
Next SubF
End Sub

Answer 1

我相信你的问题在这里：

Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WBc As Workbook
Dim shtWBc As Object
Set shtWBc = Sheets("QC Results")
Dim shtBatchwbk As Object
Dim lastrow As Long
Set shtBatchwbk = ThisWorkbook.Sheets("QC Results")
lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row

请注意，shtWBc和shtBatchwbk很可能已分配给完全相同的工作表对象。

shtBatchwbk是从ThisWorkbook分配的，除非您当时有其他工作簿处于打开/活动状态，否则shtWBc会从ActiveWorkbook分配For Each F In FF.Files If (F.Name) Like "QC_results*" & ".xlsm" Then Set WBc = Workbooks.Open(F) Set shtWBc = WBc.Sheets("QC Results") '##### ASSIGN THIS WORKSHEET FROM THE NEWLY OPNEED WORKBOOk 'Get the last row: lastrow = shtBatchwbk.Range("A65536").End(xlUp).Row ' Copy QC results range into batch summary workbook shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow) WBc.Close SaveChanges:=False Debug.Print F.Name End If Next F相同的工作簿，因此完全相同的工作表。

决议似乎是：

shtWBc.Range("A4:SA11").Copy shtBatchwbk.Range("A" & lastrow)

否则，请修改您的Q，以便根据Alexandre的评论提供更多详细信息。

评论更新

如果您只需要值，那么这应该比复制/粘贴更可靠，更快。

而不是：

shtBatchwbk.Range("A" & lastrow).Resize( _
    shtWBc.Range("A4:SA11").Rows.Count, _
    shtWBc.Range("A4:SA11").Columns.Count).Value = shtWBc.Range("A4:SA11").Value

这样做：

shtWBc.Range("A4:SA11").Copy
shtBatchwbk.Range("A" & lastrow).PasteSpecial xlPasteFormats

如果您还想复制格式而不进行完整的“复制”，因为它有时会更改/转置数字等，那么您也可以添加它：

{{1}}

循环遍历父目录中的子文件夹 - vba

1 个答案: