VBA不能复制粘贴单个值的单元格

I have a code that loop through excel files in a folder and copy the value and paste them to a new workbook.

我有一个在文件夹中循环使用excel文件的代码，并将值复制并粘贴到新的工作簿中。

The problem occur when I have files that only have a single value in the cell. It return an error stating

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

copy area and paste area aren't the same size

复制区域和粘贴区域大小不同

Below is my code:

下面是我的代码:

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

2 个解决方案

#1

First of all some thoughts to improve your coding style

1. You should avoid using Selection, Select and Activate because this is a bad practice and slows down your code a lot. You can do all actions without using them. In most cases you should never use them (there are a very little number of special cases).

   您应该避免使用选择、选择和激活，因为这是一个糟糕的做法，会大大降低代码的速度。在大多数情况下，您不应该使用它们(只有很少数量的特殊情况)。

2. Don't use eg. Range or Cells without specifying a worksheet. Otherwise Excel tries to guess which worksheet you mean and it will probably fail doing this. Guessing is not knowing, therefore always tell Excel which worksheet you mean like Worksheets(1).Range or Worksheets("SheetName").Range.

   不要使用。没有指定工作表的范围或单元格。否则，Excel会尝试猜测您指的是哪个工作表，这样做可能会失败。猜测是不知道的，因此总是告诉Excel你指的是哪个工作表(1)。.Range范围或工作表(“SheetName”)。

3. Use descriptive variable names. Names like wbk and wbk1 are not very descriptive and later you don't know what wbk1 was and mess things up. Instead use something like wbDestination and wbSource everybody knows what that means now.
   Also it might be a good practice to declare the variables close to their first use, especially when code gets a bit longer.

   使用描述性的变量名。像wbk和wbk1这样的名字不太具有描述性，之后你就不知道wbk1是什么了，把事情搞砸了。而是使用wbDestination和wbSource这样的东西，每个人都知道这意味着什么。同样，将变量声明到它们的第一次使用附近可能是一个很好的实践，特别是当代码变得更长的时候。

4. Always use Worksheets instead of Sheets if possible. Sheets also contains charts not only workbooks but in most cases you just want the Worksheets. You say it doesn't matter? Well it does. Sheets(1).Range will throw an error if the first sheet is a chart. We can avoid that.

   尽可能使用工作表而不是工作表。表还包含图表，不仅包括工作簿，而且在大多数情况下，您只想要工作表。你说没关系?好吧。表(1)。如果第一个表是图表，Range将抛出一个错误。我们可以避免。

Now lets start tidy up …

Instead of activate, select 3 times and copy

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

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

We can just copy without any ativate or select which is a lot faster and has the same effect:

我们可以复制没有任何ativate或select的速度更快，效果也一样:

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

---

When we close the source workbook

当我们关闭源工作簿时

wbSource.Close SaveChanges:=False

we don't need to save the changes because we didn't change anything. This is more secure and a lot faster.

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

So we end up with

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

Alternative way to determine the last used cell (column and row) in the source file

This avoids errors when row 2 is the last used row.

当第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

Explanation:

解释:

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

finds the last used row in column A by starting from the very last cell in Excel and going up (like pressing ctrl + up).

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

#2

I don't see why your code is thrown a Copy Area and Paste area aren't the same size error. Unless there are merged cells.

我不明白为什么您的代码被抛出了一个复制区域，而粘贴区域不是相同的大小错误。除非有合并的细胞。

Select and Active are generally used to show the user something. You can and should not use them unless absolutely necessary. I recommend watching: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)

Select和Active通常用于向用户显示某些内容。除非绝对必要，否则你可以也不应该使用它们。我推荐观看:Excel VBA介绍第5部分——选择单元格(范围、单元格、激活格、结束、偏移)

Dim Source As Range
Application.DisplayAlerts = False
Do While Len(Filename) > 0                        'IF NEXT FILE EXISTS THEN

    With Workbooks.Open(Path & Filename)
        Set Source = .Range(.Range("A" & .Rows.Count).End(xlUp), .Cells(1, 
        .Columns.Count).End(xlToLeft))
    End With

    Source.Copy Workbooks("Book1.xlsm").Range("A" & .Rows.Count).End(xlUp)
    .Close False
    Filename = Dir
Loop