Question

您知道什么需要进行以下代码调整。我设置的范围（A1：B20）随时间变化。第一个数据块位于A1：B20之间，而第二个数据块始终在A25：B60之间。范围会随着时间而变化。第一块数据可能会下降200行。在代码到达第二个数据块并且我的范围介于该数据块之间之后，只有在我手动调整范围之后，它才会选择范围。请注意，第二个数据块通常提供第一个数据块的重复项。

如何让我的代码自动选择超出范围输出的第一个数据块，而不必手动调整“范围”？

Sub CopyPaste()

Dim lastRow As Long
Dim Sheet2 As Worksheet
Dim Results As Worksheet
Dim LookupLastrow As Long


    'code line will set values from sheet 
     ("Sheet1") into ("Sheet2") starting 5 rows down.

         Set Results = Sheets("Sheet2")
         lastRow = ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, 1).End  (xlUp).row


               Range("A1:B20" & lastRowcount).Copy
               Results.Range("A" & lastRow + 5).PasteSpecial xlPasteValuesAndNumberFormats

          Application.GoTo ActiveSheet.Range("A1"), True
          Application.CutCopyMode = False


 End Sub

Answer 1

根据您显示的图片，以下代码将捕获整个顶部和底部，无论存在多少行或几列。假设您的顶部将以“ A8”开头，如图所示。您可以编辑代码以反映实际的工作表名称。

Sub CopyPaste()

    Dim OrigLastRow As Long
    Dim OrigLastCol As Long

    Dim DestLastRow As Long

    Dim OrigRng As Range

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = ThisWorkbook.Worksheets("Origin")
    Set ws2 = ThisWorkbook.Worksheets("Destination")

    OrigLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column

    DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5

    Set OrigRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(OrigLastRow, OrigLastCol))

    OrigRng.Copy
    ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats

    Application.CutCopyMode = False


End Sub

下面的版本会像您的图片一样创建顶部和底部，并分别复制两个部分，并在目标位置留出5行的间隔。

Sub CopyPaste2()

    Dim OrigLastRow As Long
    Dim OrigLastCol As Long
    Dim TopLastRow As Long
    Dim BotLastRow As Long

    Dim DestLastRow As Long

    Dim OrigTopRng As Range
    Dim OrigBotRng As Range

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = ThisWorkbook.Worksheets("Origin")
    Set ws2 = ThisWorkbook.Worksheets("Destination")

    'Assumes contiguous data from row 8 down
    TopLastRow = ws1.Cells(8, 1).End(xlDown).Row
    BotLastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    OrigLastCol = ws1.Cells(10, Columns.Count).End(xlToLeft).Column

    DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5

    'Assumes we are starting the top range in row 8
    Set OrigTopRng = ws1.Range(ws1.Cells(8, 1), ws1.Cells(TopLastRow, OrigLastCol))

    'Columns I & J as shown in the picture
    Set OrigBotRng = ws1.Range(ws1.Cells(TopLastRow + 5, 9), ws1.Cells(BotLastRow, 10))

    OrigTopRng.Copy
    ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats

    'Recalculate destination last row
    DestLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 5

    OrigBotRng.Copy
    ws2.Cells(DestLastRow, 1).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False


End Sub

Answer 2

想想简单。无需为范围地址构建字符串，也无需将剪贴板与.Copy和.Paste一起使用。 直接对单元格表中的.Value属性进行分配。

Public Sub CopyValues()

    Dim r_src As Range, r_dst As Range
    ' Source starts at row 20
    Set r_src = Sheets("Sheet 2").Cells(20, 1)
    ' Destination starts at row 5
    Set r_dst = Sheets("Sheet 1").Cells(5, 1)

    Dim n As Long
    ' Count the non-empty cells
    n = r_src.Range(r_src, r_src.End(xlDown)).Rows.Count

    ' Copy n rows and 2 columns with one command
    r_dst.Resize(n, 2).Value = r_src.Resize(n, 2).Value

End Sub

仅当范围大于20行时，复制粘贴才有效

2 个答案: