如何修改此代码以满足此要求，将数据从一个excel书籍复制到另一个excel书籍直到最后一个单元格？

Question

如何修改此代码以满足此要求： - 将数据从一个excel书籍复制到另一个excel书籍直到最后一个单元格？

代码如下：

    Sub Copy_Over()
        Application.ScreenUpdating = False
        Dim i As Integer
        Dim b As Integer
        Dim LastRow As Long
        Dim Lastrow2 As Long

        Sheets("Sheet1").Activate
        For i = 1 To 1
            LastRow = Cells(Rows.Count, i).End(xlUp).Row + 1
            Lastrow2 = Sheets("Sheet2").Cells(Rows.Count, i).End(xlUp).Row + 1

            For b = 1 To LastRow
                Sheets("Sheet2").Cells(Lastrow2, i).Value = Cells(b, i).Value
                Lastrow2 = Lastrow2 + 1
            Next
        Next
        Application.ScreenUpdating = True
    End Sub

Answer 1

只需要一行代码就可以完成整行的复制。

Option Explicit  ' always add this
Sub Copy_Over()
    Application.ScreenUpdating = False
    Dim nRow1 As Integer
    Dim LastRow1 As Long    ' use suffix, as 1/2 or From/To
    Dim LastRow2 As Long

    Sheets("Sheet1").Activate
    LastRow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    LastRow2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

    For nRow1 = 1 To LastRow1

        Sheets("Sheet2").Rows(LastRow2 + nRow1).Value = Sheets("Sheet1").Rows(nRow1).Value

    Next
    Application.ScreenUpdating = True
End Sub

Answer 2

我没有看到任何理由一次循环一行。

Option Explicit

Sub CopyOver()
    'Application.ScreenUpdating = False ' Uncomment when code is working.

    Dim sourceSheet As Worksheet
    Set sourceSheet = Application.Workbooks("Book1.xlsx").Worksheets("Sheet1")

    Dim destinationSheet As Worksheet
    Set destinationSheet = Application.Workbooks("Book2.xlsx").Worksheets("Sheet2")

    Dim lastRowOnSourceSheet As Long
    lastRowOnSourceSheet = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row

    Dim lastRowOnDestinationSheet As Long
    lastRowOnDestinationSheet = destinationSheet.Cells(destinationSheet.Rows.Count, "A").End(xlUp).Row

    If (lastRowOnDestinationSheet + 1 + lastRowOnSourceSheet) > destinationSheet.Rows.Count Then
        MsgBox "There aren't enough rows in '" & destinationSheet.Name & "'. Nothing has been copy-pasted. Code will stop running now."
        Exit Sub
    End If

    sourceSheet.Rows("1:" & lastRowOnSourceSheet).Copy
    destinationSheet.Cells(lastRowOnDestinationSheet + 1, "A").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    'Application.ScreenUpdating = True ' Uncomment when code is working.
End Sub

您也可以跳过剪贴板并直接将值从一个范围分配给另一个范围。