Question

有人可以建议如何将以下2个宏组合成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("AcctsDueToBeSusp").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

第一个Macro（上图）是将信息从Sheet 1复制到Sheet 2＆amp; 3和第二个宏（下面）是在复制到Sheet 2＆amp ;;之后从Sheet 1中删除原始信息。 3。

Sub Clear()

    Range("A2:D2").Select
    Selection.ClearContents
    Rows("3:500").Select
    Selection.ClearContents
    Range("A2").Select

End Sub

非常感谢有人能为我提供解决方案。

此致

Answer 1

如果您只有一张工作表，则放置

Call clear()

无论你想在哪里运行clear sub都可以实现这一点。

但是，如果您有多个工作表，则需要在完成清除单元格之前和之后在Clear（）子目录中指定它们。

Answer 2

你有一个子调用一个调用函数的子。我假设你只想让clear() sub成为第一个sub的一部分。只需将clear sub的内容添加到第一个ArchiveReminder()子。

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("AcctsDueToBeSusp").Columns("E:U") '<~~ paste values to 2nd worksheet

    Range("A2:D2").Select
    Selection.ClearContents
    Rows("3:500").Select
    Selection.ClearContents
    Range("A2").Select

End Sub

如何将2个宏组合成1个

2 个答案: