将基于条件的行复制到另一个工作表

Question

我一直在这个网站上寻找答案，但找不到任何相关内容，并且想知道是否有人可以提供帮助。

我有一份excel文件。

表1包含分机号码列表，例如EXT 1202.EXT 1203，EXT 1204。

片材2称为EXT 1202.片材3称为EXT 1203.片材4称为EXT 1204，依此类推。

我需要能够运行一个宏来扫描Sheet 1以查找包含单词“EXT 1202”的所有行，并将其复制到名为EXT 1202的表单中，然后该表单将复制包含单词的Sheet 1中的所有行EXT 1203并将其复制到名为1203的工作表中。

PS我正在使用Microsoft Excel 2010，它基本上可以帮助我找出哪些分机号码拨打哪些电话，并允许我向这些人收取个人电话费。我喜欢将每个分机号码的数据放在一张单独的表格上，因为如果那个人想要一份副本，我可以逐字打印每张表格。

我希望代码能够指定何时粘贴包含该单词的所有行，例如EXT 1202.是否可以将其指定为粘贴到名为“EXT 1202”的表中，但是从特定行开始，说排100？第1-99行包含我不想被覆盖的文本。是否可以自动更改正在复制和粘贴的数据的字体？

我知道这很难。我希望有人可以接受挑战，也许可以给我一个代码，我只是一个愚蠢的会计师：-S所以这将是好的。非常感谢，米歇尔

Answer 1

这是我一起扔的一些快速代码（评论所以如果需要你可以修改）。这假设您的数据在Sheet1上的单元格A2中开始，并且分机号码（在此示例中为1203/1204）位于A列中。它将抓取行并将其粘贴到各张纸上（必须设置纸张）事先），它将跳过有数据的行。与预定义的分机号码不对应的行将以黄色突出显示。希望这可以帮助！

Sub Phone_Numbers()

    'Start on the main first sheet, cell A2
    Sheets("Sheet1").Select
    Range("A2").Select

    'Loop while activecell is not blank (goes down the column)
    Do While ActiveCell <> ""
        'You need to create these for every possible extension
        '  Also, create individual worksheets for each
        If InStr(1, ActiveCell, "1203", 1) <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("Ext 1203").Select
            Range("A2").Select

        ElseIf InStr(1, ActiveCell, "1204", 1) <> 0 Then
            ActiveCell.EntireRow.Copy
            Sheets("Ext 1204").Select
            Range("A2").Select

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

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

        ActiveSheet.Paste

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

End Sub