Question

使用此代码，它将复制数据并将其粘贴到名称所属的相应相应选项卡上，但是当我再次运行它以获取下一组数据时，它会覆盖最后一个数据。我不确定如何添加措辞以粘贴到下一个空行

    Dim c As Range, namesRng As Range
    Dim name As Variant

    With Worksheets("DRIVERS") '<--| reference "DRIVERS" worskheet
        Set namesRng = .Range("A2", .Cells(.Rows.Count, "a").End(xlUp)) '<--| set the range of "drivers" in column "a" starting from row 4 down to last not empty row
    End With

    With CreateObject("Scripting.Dictionary") '<--| instance a 'Dictionary' object
        For Each c In namesRng.SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through "drivers" range cells with text content only
            .Item(c.Value) = c.Value '<--| build the unique list of names using dictionary key
        Next
        Set namesRng = namesRng.Resize(namesRng.Rows.Count + 1).Offset(-1) '<--| resize the range of "names" to have a "header" cell (not a name to filter on) in the first row
        For Each name In .Keys '<--| loop through dictionary keys, i.e. the unique names list
            FilterNameAndCopyToWorksheet namesRng, name '<--| filter on current name and copy to corresponding worksheet
        Next
    End With '<--| release the 'Dictionary' object
End Sub

Sub FilterNameAndCopyToWorksheet(rangeToFilter As Range, nameToFilter As Variant)
    Dim destsht As Worksheet

    Set destsht = Worksheets(nameToFilter) '<--| set the worksheet object corresponding to passed name
    With rangeToFilter
        .AutoFilter Field:=1, Criteria1:=nameToFilter
        Intersect(.Parent.UsedRange, .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow).Copy destsht.Cells(destsht.Rows.Count, "a").End(xlUp)
        .Parent.AutoFilterMode = False

    End With
End Sub

Answer 1

destsht.Cells(destsht.Rows.Count, "a").End(xlUp)

在上面的代码中，最后添加offset（）。

destsht.Cells(destsht.Rows.Count, "a").End(xlUp).Offset(1)

需要在下一个空格中粘贴信息

1 个答案: