Question

我对VBA非常陌生，因为这个问题而陷入困境一个月，请你真的需要帮助

我每个月都会启动一个新的excel文件，我需要为列表中的文本搜索特定的日期间隔（1-10,11-20,21-31），然后将第1行中的行复制到第3页日期格式是dd.mm.yyyy和F列。我搜索的文字在B栏。我设法搜索列表中的每个项目和每个日期但是它变得荒谬，因为我在我的项目中大约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-10选择日期，我的列表是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

这是我迄今为止设法做到的，它只搜索第一个标准，名单列表，我只是不知道如何使其搜索以符合日期< / p>

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左侧的第一列作为“助手”。所以没有相关数据必须在列中，因为它们将被覆盖

使用两个标准进行搜索并复制行

1 个答案: