Question

我有一个代码循环浏览文件夹中的excel文件并复制该值并将其粘贴到新工作簿中。

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

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

以下是我的代码：

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

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

您应该避免使用Selection，Select和Activate，因为这是一种不好的做法并且会大大减慢您的代码速度。您可以不使用它们来执行所有操作。在大多数情况下，你永远不应该使用它们（特殊情况很少）。
不要使用eg。 Range或Cells未指定工作表。否则，Excel会尝试猜测您的工作表是什么意思，它可能会失败。猜测不知道，因此总是告诉Excel你的工作表是Worksheets(1).Range还是Worksheets("SheetName").Range。
使用描述性变量名称。像wbk和wbk1这样的名称不是很具描述性，后来你也不知道wbk1是什么并搞砸了。而是使用像wbDestination和wbSource之类的东西，每个人都知道这意味着什么同样，将变量声明为第一次使用时也是一个好习惯，特别是当代码变得更长时。
如果可能，请始终使用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

我们可以在没有任何激活的情况下进行复制，也可以选择更快且具有相同效果的选项：

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 ）。

Answer 2

我不明白为什么您的代码会引发Copy Area and Paste area aren't the same size错误。除非有合并的单元格。

选择和活动通常用于向用户显示某些内容。除非绝对必要，否则您可以而且不应该使用它们。我建议观看：Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)

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

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

2 个答案:

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

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

所以我们最终得到了

确定源文件