使用两个标准进行search并复制行

我对VBA非常陌生，在这个问题上被困了一个月，真的需要你的帮助

我每个月都会创build一个新的excel文件，我需要为列表中的文本search特定的date间隔（1-10，11-20，21-31），然后将表1中的行复制到表3.date格式是dd.mm.yyyy和F栏。我search的文本是在B列。我设法search列表中的每个项目，每一个date，但它变得荒谬，因为我在列表中的30个项目和31一个月中的一天，有些项目每个月都在变化。

1 TOM xxxxxx xxxxxx xxxxxx 02.03.2016 xxxxxx xxxxxx xxxxxx

2 MARY xxxxxx xxxxxx xxxxxx 14.03.2016 xxxxxx xxxxxx xxxxxx

3 TOM xxxxxx xxxxxx xxxxxx 20.03.2016 xxxxxx xxxxxx xxxxxx

4 ANNA xxxxxx xxxxxx xxxxxx 01.03.2016 xxxxxx xxxxxx xxxxxx

5 EMMA xxxxxx xxxxxx xxxxxx 02.03.2016 xxxxxx xxxxxx xxxxxx

6 JUSTIN xxxxxx xxxxxx xxxxxx 04.03.2016 xxxxxx xxxxxx xxxxxx

所以如果我从1-10selectdate，我的名单是TOM，MARY，EMMA

1 TOM xxxxxx xxxxxx xxxxxx 02.03.2016 xxxxxx xxxxxx xxxxxx

2 EMMA xxxxxx xxxxxx xxxxxx 02.03.2016 xxxxxx xxxxxx xxxxxx

这是我迄今为止设法做的，它只search第一个标准，名单的名单，我只是不知道如何使其search也符合date

Sub Names() Dim LR As Long, i As Long, j As Long, Names, Day, l As Long Dim k As Long k = 13 Dim tocopy As Integer Sheets(2).Range("A13:R250").Clear Names= Array("TOM", "MARY", "EMMA") Day = Array("01.03.2016", "02.03.2016", "03.03.2016", "04.03.2016", "05.03.2016", "06.03.2016", "07.03.2016", "08.03.2016", "09.03.2016", "10.03.2016") LR = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LR With Range("B" & i) For j = LBound(Names) To UBound(Names) If .Value Like "*" & Names(j) & "*" Then tocopy = 1 Exit For End If Next j End With If tocopy = 1 Then Rows(i).Copy Destination:=Sheets(3).Rows(k) k = k + 1 End If tocopy = 0 Next i End Sub 

Answer 1

你可以试试这个

 Option Explicit Sub main() Dim namesArray As Variant, daysInterval As Variant Dim dataRng As Range Dim sourceSht As Worksheet, destSheet As Worksheet namesArray = Array("TOM", "MARY", "EMMA") '<== here set the names to search for daysInterval = Array(11, 20) '<== here set the days interval Set sourceSht = ThisWorkbook.Worksheets("source") '<== here set the name of the worksheet with data to filter Set destSheet = ThisWorkbook.Worksheets("destination") '<== here set the name of the worksheet where to paste filtered data into Set dataRng = sourceSht.Range("A13:R250") ' here set range with data to be filtered with names and days. it MUST include headers row With dataRng With .Resize(, .Columns.Count + 1) .Columns(.Columns.Count).Offset(1).Resize(.Rows.Count - 1).FormulaR1C1 = "=if(ISTEXT(RC6),value(LEFT(RC6,2)),"""")" .AutoFilter Field:=2, Criteria1:=namesArray, Operator:=xlFilterValues .AutoFilter Field:=.Columns.Count, Criteria1:=">=" & daysInterval(0) & "", Operator:=xlAnd, Criteria2:="<=" & daysInterval(1) & "" End With With .Offset(1).Resize(.Rows.Count - 1) If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 0 Then .SpecialCells(xlCellTypeVisible).Copy Destination:=destSheet.Rows(13) End With .AutoFilter .Columns(.Columns.Count + 1).Clear End With End Sub 

与以下关键笔记

• 小心妥善设置你发现评论的地方“ '<== here set... ”

• 该代码使用dataRng左侧的第一列作为“帮手”之一。 所以没有相关的数据必须在列中，因为它们会被覆盖