使用宏行复制到另一个工作表，如果它满足标准

Question

我在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 

我试图让擅长每一行，说复制无论是苹果，浆果，或上个月的樱桃（在这种情况下 - 2013年9月1日 - 2013年9月30日），并放入相应的表格中。表名是苹果，浆果和樱桃。然后插入一行并将行添加到最后一行数据后面的行中。我还需要它将a列中的下一个数字复制到相应的表格中。因此，第6行将在第a列中具有数字6。

我尝试了一些VBA代码，但我有一些麻烦，使其动态搜索所有表名称而不是“苹果”。此外，我无法找到数据的最后一行。请参阅下面我的代码：

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 

Answer 1

我修改你的代码，所以不是照搬行1减1，它自动过滤器，复制整个应用范围的一次。此外，这假定任何未命名为“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 

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