同时循环遍历目录和文件

Question

我试图将几个excel文件中的值复制到一个。我试图通过首先循环目录然后文件来实现这一点。但是，我得到一个错误，说源单元的大小不等于目标范围。

For Each cell In ThisWorkbook.Sheets("Info").Range("b8:b9")
    MsgBox (cell)
    strfile = Dir$(cell & "\" & "*.xlsm", vbNormal)

    While strfile <> ""
        MsgBox (strfile)
        ' Open the file and get the source sheet
        Set wbSource = Workbooks.Open(cell & "\" & strfile)
        Set inSource = wbSource.Sheets("OUTPUT_INSTRUMENT")
        Set enSource = wbSource.Sheets("OUTPUT_ENTITY")
        Set prSource = wbSource.Sheets("OUTPUT_PROTECTION")

        'Copy the data
        Call CopyHeaders(inSource, inTarget, enSource, enTarget, prSource, prTarget)
        Call CopyData(inSource, inTarget, enSource, enTarget, prSource, prTarget)

        'Close the workbook and move to the next file.
        wbSource.Close False
        strfile = Dir$()
    Wend
Next cell

这些是B8中的值：B9

C:\Users\gdsg\Desktop\One
C:\Users\gdsg\Desktop\Two

这些文件夹中的每一个都有多个文件，我们首先检查这两个目录，然后查看DIR()的所有文件。也许一个出路是用While取代For each循环？

---

请在下面找到其他定义。源表通过目录循环。

Set inTarget = ThisWorkbook.Sheets("Instrument")
Set enTarget = ThisWorkbook.Sheets("Entity")
Set prTarget = ThisWorkbook.Sheets("Protection")

 Sub CopyData(ByRef inSource As Worksheet, inTarget As Worksheet, enSource As Worksheet, enTarget As Worksheet, prSource As Worksheet, prTarget As Worksheet)

inSource.Range("5" & ":" & inSource.Rows.Count).Copy
inTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

enSource.Range("5" & ":" & enSource.Rows.Count).Copy
enTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

prSource.Range("5" & ":" & prSource.Rows.Count).Copy
prTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = xlCopy

End Sub

Answer 1

这是因为你试图粘贴更多的行然后就可以了

同

inSource.Range("5" & ":" & inSource.Rows.Count).Copy

你正在复制所有的源表格行，但是前五个，而是

inTarget.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats

您将它们粘贴在目标表中，从A列中最后一个非空值之后的行开始

但如果后一个索引大于5那么你的目标表没有空间容纳所有这些行

所以你必须复制你实际需要的确切行数

然后你可以考虑这个助手子

Sub CopySingleSheetData(sourceSheet As Worksheet, targetSht As Worksheet)
    With sourceSheet
        Intersect(.UsedRange, .Rows(5).Resize(.UsedRange.Rows.Count)).Copy
    End With
    targetSht.Range("A" & targetSht.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = xlCopy
End Sub

您可以从CopyData() sub调用，如下所示

Sub CopyData(ByRef inSource As Worksheet, inTarget As Worksheet, enSource As Worksheet, enTarget As Worksheet, prSource As Worksheet, prTarget As Worksheet)
    CopySingleSheetData inSource, inTarget        
    CopySingleSheetData enSource, enTarget        
    CopySingleSheetData prSource, prTarget        
End Sub

Answer 2

尝试使用此代码将多个Excel合并为一个，

Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As    Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")
Set dirObj = mergeObj.Getfolder("\\C:target folder here\")          
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)
Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
ThisWorkbook.Worksheets(1).Activate
Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next 
End Sub

它会工作