Question

我对VBA完全不熟悉并尝试设置一些宏来将一系列数据从一个工作表复制到同一工作簿中的另外两个工作表。

我找到了一些代码，可以让我复制整个范围并将其粘贴到工作表2中的下一个空行（A列到Q列）。但是，我无法弄清楚如何在没有标题的情况下复制它（工作表1中的第一行）以及如何将其循环粘贴到工作表3（列E到U）。

我想设置的Marco是允许我将表格从A2行：Q2复制到sheet1上A列的最后一行（每次最后一行不同），然后将（作为值）粘贴到工作表2的A列中的下一个空行。然后将同一个表粘贴到工作表3上E列的下一个空行。一旦信息被复制，它将从A2：D2中删除信息，并从第3行到第1行的最后一行删除所有信息。

请帮助我，因为我对论坛和互联网上的信息感到困惑。任何援助将不胜感激。感谢

Sub ArchiveReminder()

Application.ScreenUpdating = False
Dim i As Integer
Dim b As Integer
Dim lastRow As Long
Dim Lastrow2 As Long
Sheets("MailMerge-Reminder").Activate
    For i = 1 To 17
        lastRow = Cells(Rows.Count, i).End(xlUp).Row + 1
        Lastrow2 = Sheets("Archive-Reminder").Cells(Rows.Count, i).End(xlUp).Row + 1
    For b = 2 To lastRow
        Sheets("Archive-Reminder").Cells(Lastrow2, i).Value = Cells(b, i).Value
        Lastrow2 = Lastrow2 + 1
    Next
    Next
Application.ScreenUpdating = True

End Sub

更新 - 刚刚发现我使用的代码存在问题（即如果表2中B列的最后一条记录是单元格＆＃34; B10＆＃34;而A列是单元格＆＃34; A11＆＃34 ;然后，B列中的信息将从单元格＆＃34; B11＆＃34;而不是＆＃34; B12＆＃34;中粘贴。

Answer 1

你可以像下面那样

Option Explicit

Sub ArchiveReminder()

    Dim rngToCopyFrom As Range

    With Worksheets("MailMerge-Reminder").Columns("A:Q")
        Set rngToCopyFrom = .Resize(LastColumnsRow(.Cells) - 1).Offset(1)
    End With

    PasteRangeValuesToWorksheet rngToCopyFrom, Worksheets("Archive-Reminder").Columns("A:Q") '<~~ paste values to 1st worksheet
    PasteRangeValuesToWorksheet rngToCopyFrom, Worksheets("Archive-Reminder2").Columns("E:U") '<~~ paste values to 2nd worksheet

End Sub


Sub PasteRangeValuesToWorksheet(rngToCopyValuesFrom As Range, rngToPasteTo As Range)
    'pastes values from the range passed as the first parameter to the range passed as the second parameter
    Dim lastRow As Long
    With rngToPasteTo
        lastRow = LastColumnsRow(.Cells) '<~~ get last non empty row between all columns of the range to paste to
        .Resize(rngToCopyValuesFrom.Rows.Count, rngToCopyValuesFrom.Columns.Count).Offset(IIf(lastRow = 1, 0, lastRow)).Value = rngToCopyValuesFrom.Value '<~~ paste values
    End With
End Sub


Function LastColumnsRow(rng As Range) As Long
    'gets last non empty row between all columns of the passed range
    Dim maxRow As Long, lastRow As Long
    Dim cell As Range
    With rng
        For Each cell In .Resize(1)
            lastRow = .Parent.Cells(.Parent.Rows.Count, cell.Column).End(xlUp).Row
            If lastRow > maxRow Then maxRow = lastRow
        Next cell
    End With
    LastColumnsRow = maxRow
End Function

如何将一系列数据复制并粘贴到多个工作表而没有标题

1 个答案: