VBA無法復制和粘貼單個值的單元格

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

首先是一些改進編碼風格的想法

1. 您應該避免使用“ Selection ，“ Select和“ Activate因為這是一種不好的做法並且會大大減慢您的代碼速度。 您可以不使用它們來執行所有操作。 在大多數情況下，你永遠不應該使用它們（特殊情況很少）。

2. 不要使用例如。 Range或Cells而不指定工作表。 否則，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

我們可以在沒有任何激活的情況下進行復制，也可以選擇更快且具有相同效果的選項：

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中的最后一個單元格開始並向上（例如按ctrl + 向上 ）查找A列中最后一次使用的行。

Answer 2

我不明白為什么你的代碼被拋出一個Copy Area and Paste area aren't the same size錯誤。 除非有合並的細胞。

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