1

我目前正在运行以下脚本

Sub Gift_Certificate()

    'Select Bridge Data from tab, cell A2
    Sheets("Bridge Data").Select
    Range("A2").Select

    'Loop while activecell is not blank (goes down the column)
    Do While ActiveCell <> ""
        'Repeat below step if data needs to be sorted into multiple wksts'
        '  Also, create individual worksheets for each
        If InStr(1, ActiveCell, "Gift Certificate", 1) <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("GC Redeemed").Select
            Range("A10").Select

        Else
            'If it's not an extension you have specified, it highlites the cell because its cool'
            ActiveCell.Interior.ColorIndex = 6
            GoTo SKIPPING
        End If

        Range("A10").Select
        'Loops down until there's an open cell'
        Do While ActiveCell <> ""
            ActiveCell.Offset(1, 0).Select
        Loop

        ActiveSheet.PasteSpecial

        'Go back to the starting sheet & iterate to the next row
        Sheets("Bridge Data").Select
SKIPPING:
        ActiveCell.Offset(1, 0).Select
    Loop

End Sub

我正在使用它来扫描一个选项卡上的数据并将选择的数据复制到另一个选项卡上。我遇到的问题是我想从新粘贴的数据中运行公式，但是当脚本运行时，它会将新行插入选项卡，将我的所有公式向下推。

我只想让脚本将数据复制到新选项卡中，而不是插入。

有什么建议吗？

ps，我在vb方面的经验几乎为零，所以请放心！

谢谢，

-肖恩

4

1 回答 1

0

这是一种非常不同的方法，它使用过滤来选择满足您条件的范围并将其复制到目标工作表的末尾。我不确定它将如何影响您的公式要求，但请尝试一下：

Sub Gift_Certificate()
Dim wsSource As Excel.Worksheet
Dim wsTarget As Excel.Worksheet
Dim SourceLastRow As Long
Dim TargetNextRow As Long

Set wsSource = ThisWorkbook.Sheets("Bridge Data")
Set wsTarget = ThisWorkbook.Sheets("GC Redeemed")
'Find the next empty row in the target sheet
With wsTarget
    TargetNextRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
With wsSource
    'Find the last filled row in the source sheet
    SourceLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    'Turn off any Autofilters in case they are in other columns
    'I think this is the best way to handle this
    If .AutoFilterMode Then
        .AutoFilterMode = False
    End If
    'Filter to non-matching, and fill with yellow
    .Range("A1").AutoFilter Field:=1, Criteria1:="<>Gift Certficate*", Operator:=xlAnd
    .Range("A2:A" & SourceLastRow).Interior.ColorIndex = 6
    'Filter to matching and copy to target sheet
    .Range("A1").AutoFilter Field:=1, Criteria1:="=Gift Certficate*", Operator:=xlAnd
    .Range("A2:A" & SourceLastRow).EntireRow.Copy Destination:= _
                                                  wsTarget.Range("A" & TargetNextRow)
'Turn off autofilter
    .AutoFilterMode = False
End With
End Sub
于 2012-09-18T23:56:43.720 回答