vba 如果满足条件，则使用宏将行复制到另一个工作表中

use macro to copy a row into another worksheet if it meets a criteria

提问by paul

I have a sheet in excel as below

我在 excel 中有一张工作表，如下所示

1   apple   8/1/2013    8/2/2013    99373        11
2   apple   8/13/2013   8/3/2013    2626282    2121
3   berry   8/12/2013   8/4/2013    1289127     123
4   berry   8/15/2013   8/5/2013    12712671   1234
5   cherry  8/19/2013   8/6/2013    127127     3354
    apple   9/1/2013    9/5/2013    123456      200
    apple   9/2/2013    9/6/2013    246810      300
    berry   9/3/2013    9/7/2013    3691215     400
    berry   9/4/2013    9/8/2013    48121620    500
    cherry  9/5/2013    9/9/2013    510152025   600
    cherry  9/6/2013    9/10/2013   612182430   700
    apple   9/7/2013    9/11/2013   714212835   800
    berry   9/8/2013    9/12/2013   816243240   900
    berry   9/9/2013    9/13/2013   918273645   1000
    apple   9/10/2013   9/14/2013   10203040    1100

I am trying to get excel to copy every row that says either apple, berry, or cherry for the previous month (in this case - 9/1/13 - 9/30/13) and put them in the corresponding sheets. The sheet names are apple, berry and cherry. It then inserts a row and adds the row to the row after the last row with data. I also need it to generate the next number in the series in column a before copying it to the corresponding sheet. So row 6 would have the number 6 in column a.

我试图让 excel 复制上个月（在这种情况下 - 9/1/13 - 9/30/13）的每一行，上面写着苹果、浆果或樱桃，并将它们放在相应的工作表中。工作表名称是苹果、浆果和樱桃。然后插入一行并将该行添加到包含数据的最后一行之后的行中。在将其复制到相应的工作表之前，我还需要它在 a 列中生成系列中的下一个数字。因此，第 6 行将在 a 列中包含数字 6。

I have tried some VBA code but I am having some trouble making it dynamic to search all the sheet names rather than just "apple". Also I am having trouble finding the last row with data. Please see below my code:

我已经尝试了一些 VBA 代码，但是我在使其动态搜索所有工作表名称而不仅仅是“apple”时遇到了一些麻烦。我也无法找到包含数据的最后一行。请看下面我的代码：

Sub testIt()
Dim r As Long, endRow As Long, pasteRowIndex As Long

endRow = 15
pasteRowIndex = 1

For r = 1 To endRow

    If Cells(r, Columns("B").Column).Value = "apple" Then


        Rows(r).Select
        Selection.Copy


        Sheets("apple").Select
        Rows(pasteRowIndex).Select
        ActiveSheet.Paste


        pasteRowIndex = pasteRowIndex + 1



        Sheets("Sheet1").Select
    End If
Next r
End Sub

采纳答案by paul

I modified your code so instead of copying rows 1 by 1, it auto-filters, copying the entire applicable range at once. Also, this assumes that any worksheet not named "Sheet1" will be used as search and copy criteria.

我修改了您的代码，因此它不会逐一复制行，而是自动过滤，一次复制整个适用范围。此外，这假定任何未命名为“Sheet1”的工作表都将用作搜索和复制条件。

Application.CutCopyMode = False

Dim r As Long, c As Long
Dim ws As Worksheet
Dim sFruit As String
Dim wsRow as Long

Worksheets("Sheet1").Activate
r = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row 'find last row
c = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column 'find last column
Range("A1").AutoFilter
Range("C1:C" & r).AutoFilter Field:=3, Criteria2:=Array(1, "9/30/2013") 'filters for month of Sep'13

For Each ws In Worksheets
    If ws.Name <> "Sheet1" Then
        '*edited to accommodate pre-existing data
        ws.Activate '*activate sheet so you can use Cells() with it
        wsRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row + 1 '*find first usable row in ws
        sFruit = ws.Name 'criteria to look for
        Worksheets("Sheet1").Activate 'bring focus back to main sheet
        Range("B1:B" & r).AutoFilter Field:=2, Criteria1:=sFruit
        Range(Cells(2, 1), Cells(r, c)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A" & wsRow)
    End If
Next ws

Range("A1").AutoFilter

Application.CutCopyMode = True

You can add functionality to filter by dates. I would suggest recording yourself using auto-filter so you can get an idea on how to modify the code.

您可以添加按日期过滤的功能。我建议使用自动过滤器记录自己，以便您了解如何修改代码。