VBA无法复制和粘贴具有单个值的单元格

Question

我有一个代码，可以循环遍历文件夹中的 Excel 文件并复制值并将其粘贴到新工作簿中。

当我的文件的单元格中只有一个值时，就会出现此问题。它返回一个错误，指出

copy area and paste area aren't the same size

下面是我的代码:

Sub MergeDataFromWorkbooks()
    'DECLARE AND SET VARIABLES
    Dim wbk As Workbook
    Dim wbk1 As Workbook
    Set wbk1 = ThisWorkbook

    Dim Filename As String
    Dim Path As String
    Path = "C:\Users\Desktop\merge all to one\" 'CHANGE PATH ACCORDING TO FOLDER DIRECTORY LEAVING \ AT THE END
    Filename = Dir(Path & "*.xlsx")

    '--------------------------------------------
    'OPEN EXCEL FILES
    Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
        Set wbk = Workbooks.Open(Path & Filename)
        wbk.Activate
        Range("A2").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("Book1.xlsm").Activate
        Application.DisplayAlerts = False

        Dim lr As Double
        lr = wbk1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

        Sheets(1).Select
        Cells(lr + 1, 1).Select
        ActiveSheet.Paste
        wbk.Close True
        Filename = Dir
    Loop

    MsgBox "All the files are copied and pasted in Book1."
End Sub

Answer 1

首先，一些改进编码风格的想法

1. 您应该避免使用 Selection、Select 和 Activate，因为这是一种不好的做法，并且会大大减慢您的代码速度。您无需使用它们即可执行所有操作。在大多数情况下，您不应该使用它们(有极少数特殊情况)。

2. 不要使用例如。不指定工作表的范围或单元格。否则，Excel 会尝试猜测您指的是哪个工作表，并且可能会失败。猜测并不等于知道，因此始终告诉 Excel 您指的是哪个工作表，例如 Worksheets(1).Range 或 Worksheets("SheetName").Range .

3. 使用描述性变量名称。像 wbk 和 wbk1 这样的名称并不是很具有描述性，后来你不知道 wbk1 是什么，并且把事情搞砸了。而是使用诸如 wbDestination 和 wbSource 之类的东西，现在每个人都知道这意味着什么。
   此外，在变量接近首次使用时声明变量可能是一个好习惯，尤其是当代码变得更长时。

4. 如果可能，请始终使用 Worksheets 而不是 Sheets。 Sheets 还包含图表，不仅包含工作簿，而且在大多数情况下您只需要 Worksheets。你说没关系？确实如此。如果第一个工作表是图表，Sheets(1).Range 将引发错误。我们可以避免这种情况。

现在让我们开始整理......

不要激活，而是选择3次并复制

wbk.Activate
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

我们可以直接复制而不需要任何 activate 或 select，这样速度更快并且具有相同的效果:

With wbSource.Worksheets(1).Range("A2")
    'copy without select
    .Resize(.End(xlDown).Row - .Row + 1, .End(xlToRight).Column - .Column + 1).Copy
End With

<小时/>

当我们关闭源工作簿时

wbSource.Close SaveChanges:=False

我们不需要保存更改，因为我们没有更改任何内容。这更安全并且速度更快。

所以我们最终得到

Option Explicit

Sub MergeDataFromWorkbooks()
    Dim wbDestination As Workbook
    Set wbDestination = ThisWorkbook

    Dim Path As String
    Path = "C:\Temp\" 'make sure it ends with \

    Dim Filename As String
    Filename = Dir(Path & "*.xlsx")

    Do While Len(Filename) > 0 'while file exists
        Dim wbSource As Workbook
        Set wbSource = Workbooks.Open(Path & Filename)    

        With wbSource.Worksheets(1).Range("A2")
            'copy without select
            .Resize(.End(xlDown).Row - .Row + 1, .End(xlToRight).Column - .Column + 1).Copy
        End With

        Dim lRow As Double
        lRow = wbDestination.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'find next empty row

        wbDestination.Worksheets(1).Cells(lRow + 1, 1).PasteSpecial Paste:=xlPasteAll 'paste all

        wbSource.Close SaveChanges:=False 'we don't need to save changes we didn't change anything just copied
        Filename = Dir 'next file
    Loop

    MsgBox "All the files are copied and pasted in Book1."
End Sub

确定源文件中最后使用的单元格(列和行)的替代方法

这可以避免当第 2 行是最后使用的行时出现错误。

With wbSource.Worksheets(1).Range("A2")
    .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row - .Row + 1, .Parent.Cells(.Row, .Parent.Columns.Count).End(xlToLeft).Column - .Column + 1).Copy
End With

说明:

.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).Row

从 Excel 中的最后一个单元格开始向上查找 A 列中最后使用的行(例如按 ctrl + up)。