Как изменить этот код для этого требования, чтобы копировать данные из одной книги Excel в другую до последней ячейки?

Question

Как мне изменить этот код, чтобы он отвечал этому требованию: - копировать данные из одной книги 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

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

Вы также можете пропустить буфер обмена и напрямую присвоить значение из одного диапазона другому.

Answer 2

Для копирования всей строки требуется всего одна строка кода.

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