扩大范围

Question

下面是将多个工作簿合并到一个工作簿中的代码。但是，一旦完成该过程，从本地文件夹中提取的文件就不完整。我的猜测是该本地文件夹中的工作簿/文件远远超出了代码中的范围。

如何扩展范围，最好是＆＃34;无限制＆＃34;或尽可能多地转移和合并工作簿？

以下是我使用的代码。

请提出建议，我们非常感谢您的帮助。

文森特

Sub Merger()
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:\Users\Vincent\Desktop\856")

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

Application.DisplayAlerts = False

Next
End Sub

Answer 1

要猜测并说你正在为复制和粘贴寻找两个动态范围：

dim lrs as long, lrd as long 'last row source/destination
'could also look for last column dynamically

'inside of your loop
with everyObj.sheets("")
    lrs = .cells(.rows.count,1).end(xlup).row
    .range(.cells(1,1),.cells(lrs,"iv").copy
end with
with thisworkbook.sheets("")
    lrd = .cells(.rows.count, 1).end(xlup).row
    .range(.cells(lrd+1,1),.cells(lrd+1+lrs,"iv").paste
end with

未经测试的代码，在黑暗中拍摄。如果你使用正确的代码到达那里，你应该能够在excel中添加几乎无限的行。

我建议关闭每个源文件并指定为NOT SAVE（后者在代码中显示为缺失）。

Answer 2

你需要找到范围的最后一行或结尾，试试这个：

Sub Merger()
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:\Users\Vincent\Desktop\856")

Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

' find last row in column A
Dim last_row As Long
With ActiveSheet
    last_row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Range("A2:IV" & Range("A" & last_row).End(xlUp).Row).Copy

ThisWorkbook.Worksheets(1).Activate

Range("A" & last_row).End(xlUp).Offset(1, 0).PasteSpecial

Application.CutCopyMode = False
bookList.Close

Application.DisplayAlerts = False

Next
End Sub

Answer 3

应该使用

Range().Rows.Count对最后一行进行硬编码。范围内的所有引用都应该是完全限定的（参考源工作表）。使用With WorkBook.Worksheet块将确保您每次都返回正确的范围。

With bookList.Worksheets(1)
    .Range("A2:IV2", .Range("A" & .Rows.Count).End(xlUp))
End With

仅当您需要包含格式时才应使用

Range.Copy。 Range.Value返回Range中的值数组。

Application.DisplayAlerts = False应位于bookList.Close之前。最好使用Workbook.Close SaveChanges:=False，无需停用DisplayAlerts（例如bookList.Close SaveChanges:=False）

Sub Merger()
    Application.ScreenUpdating = False
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Dim Source As Range, Target As Range
    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    Set dirObj = mergeObj.Getfolder("C:\Users\Vincent\Desktop\856")

    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        With bookList.Worksheets(1)
            Set Source = .Range("A2:IV2", .Range("A" & .Rows.Count).End(xlUp))
        End With

        With ThisWorkbook.Worksheets(1)
            Set Target = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
        End With

        Target.Resize(Source.Rows.Count, Source.Columns.Count).Value = Source.Value

        bookList.Close SaveChanges:=False
    Next

    Application.ScreenUpdating = True
End Sub

附录

当前的“范围限制”为1048576 Rows x 16384 Columns。此代码将范围从A2:V2扩展到CSV文件的Column A中的最后一个使用的单元格。如果Column A中的数据未延伸到列表末尾，请将.Range("A"更改为相应的列。

Set Source = .Range("A2:IV2", .Range("A" & .Rows.Count).End(xlUp)

您应该在bookList.Close设置断点并测试范围。

Immediate Window

  

？Source.Address，Target.Resize（Source.Rows.Count，Source.Columns.Count）.Address

Answer 4

你可以试试这个

Option Explicit

Sub Merger()
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Dim targetSht As Worksheet

    Set targetSht = ThisWorkbook.Worksheets(1)
    Application.ScreenUpdating = False

    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    Set dirObj = mergeObj.Getfolder("C:\Users\Vincent\Desktop\856")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Select Case mergeObj.GetExtensionName(everyObj)
            Case "csv" ' handle only "csv" files (you can extend the list of allowed extensions)
                With Workbooks.Open(everyObj).Worksheets(1) ' open current file as a workbook and reference its first worksheet 
                    With Intersect(.UsedRange, .UsedRange.Offset(1)) ' reference referenced worksheet "used" range except its first row
                        If targetSht.UsedRange.Rows(targetSht.UsedRange.Rows.Count).Row + .Rows.Count <= targetSht.Rows.Count Then ' if target sheet has room for current file rows 
                            .Copy targetSht.Cells(targetSht.Rows.Count, 1).End(xlUp).Offset(1)
                        Else
                            MsgBox "not enough room in " & targetSht.Name & " for " & everyObj.Name
                        End If
                    End With
                    .Parent.Close False
                End With
        End Select
    Next
    Application.ScreenUpdating = True
End Sub