Question

我在这里设置了一个很好的帮助，设置一个搜索功能，从一张纸上的单元格中获取更改的输入，并在不同的工作表中搜索数据匹配，无论输入是什么（在这种情况下，它是一个名称）。然后，代码返回与输入匹配的每一行中的3列数据。这很好用，我很感谢你的帮助。现在我试图改变同样的概念来覆盖更多的列（这很容易）。但是，我需要将搜索参数更改为日期范围而不是名称输入。我在这里找到了日期范围搜索的答案，但我很难让它发挥作用。这就是我现在所拥有的。

Sub ARange()
Dim Sh As Worksheet: Set Sh = Sheets("Sheet1")
Dim SRCH As Worksheet: Set SRCH = Sheets("Sheet2")
Dim i, j As Integer

LookupColumn = "A" 'Define the LookupColum / If you find using column index to be simpler then you need to switch the search from (range) to (cells)
StartDate_Value = SRCH.Range("a1").Value 'Use whatever you need to define the input values
EndDate_Value = SRCH.Range("a2").Value 'Use whatever you need to define the input values

For i = 1 To 30000
    If Sh.Range(LookupColumn & i).Value = EndDate_Value Then EndDate_Row = i
Next i

For j = EndDate_Row To 1 Step -1
    If Sh.Range(LookupColumn & j).Value = StartDate_Value Then StartDate_Row = j
Next j

    Call ExtractData

'Dim MyDateRange As Range: Set MyDateRange = Sh.Range(LookupColumn & StartDate_Row & ":" & LookupColumn & EndDate_Row)
'MsgBox "MyDateRange = " & LookupColumn & StartDate_Row & ":" & LookupColumn & EndDate_Row
End Sub
Sub ExtractData()
    Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
    Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2")

    Dim LastRow As Long, RowCounter As Long
    Dim SearchRange As Range, FoundRange As Range, rw As Range
    Dim Val As String: Val = wsDest.Range("a1")
    'Call ARange

    With wsSrc
        LastRow = .UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set SearchRange = .Range("A2", .Cells(LastRow, "H")) 'A2-H
        Set FoundRange = FindAll(Val, SearchRange)

    End With

    'Clear Destination Sheet (except header row)
    With wsDest
        On Error Resume Next
        Application.Intersect(wsDest.UsedRange, wsDest.UsedRange.Offset(1, 0)).ClearContents
        On Error GoTo 0
    End With

    ' Copy Data
    RowCounter = 2
    Set FoundRange = Union(FoundRange, FoundRange.EntireRow.Rows) 'Expand Range to entire rows of Range
    For Each rw In FoundRange.Rows
        wsDest.Cells(RowCounter, 2) = wsSrc.Cells(rw.Row, 1)
        wsDest.Cells(RowCounter, 3) = wsSrc.Cells(rw.Row, 2)
        wsDest.Cells(RowCounter, 4) = wsSrc.Cells(rw.Row, 3)
        wsDest.Cells(RowCounter, 5) = wsSrc.Cells(rw.Row, 4)
        wsDest.Cells(RowCounter, 6) = wsSrc.Cells(rw.Row, 5)
        wsDest.Cells(RowCounter, 7) = wsSrc.Cells(rw.Row, 6)
        wsDest.Cells(RowCounter, 8) = wsSrc.Cells(rw.Row, 7)
        wsDest.Cells(RowCounter, 9) = wsSrc.Cells(rw.Row, 8)
        RowCounter = RowCounter + 1
    Next rw

End Sub


Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

在这个例子中，我正在调用＆＃39; ExtractData＆＃39;运行日期搜索后的子程序。我已经尝试过另一种方式来运行“ExtractData”＆＃39; sub并打电话给＆＃39; ARange＆＃39;子。但是，当以另一种方式运行时，＆＃39; ARange＆＃39;只返回消息框，对搜索没有影响。如果我删除＆＃39; ARange＆＃39;然后运行“ExtractData”＃39;但输入一个日期，搜索会提取该日期所有条目所需的信息。所以如果有办法改变'ExtractData＆＃39;用于搜索给定日期范围的模块，这将是最简单的。我在下面列出了“ExtractData”＆＃39;模块本身。任何帮助表示赞赏。

Sub ExtractData()
Dim wsSrc As Worksheet: Set wsSrc = Worksheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = Worksheets("Sheet2")

Dim LastRow As Long, RowCounter As Long
Dim SearchRange As Range, FoundRange As Range, rw As Range
Dim Val As String: Val = wsDest.Range("a1")


With wsSrc
    LastRow = .UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set SearchRange = .Range("A2", .Cells(LastRow, "H")) 'A2-H
    Set FoundRange = FindAll(Val, SearchRange)

End With

'Clear Destination Sheet (except header row)
With wsDest
    On Error Resume Next
    Application.Intersect(wsDest.UsedRange, wsDest.UsedRange.Offset(1, 0)).ClearContents
    On Error GoTo 0
End With

' Copy Data
RowCounter = 2
Set FoundRange = Union(FoundRange, FoundRange.EntireRow.Rows) 'Expand Range to entire rows of Range
For Each rw In FoundRange.Rows
    wsDest.Cells(RowCounter, 2) = wsSrc.Cells(rw.Row, 1)
    wsDest.Cells(RowCounter, 3) = wsSrc.Cells(rw.Row, 2)
    wsDest.Cells(RowCounter, 4) = wsSrc.Cells(rw.Row, 3)
    wsDest.Cells(RowCounter, 5) = wsSrc.Cells(rw.Row, 4)
    wsDest.Cells(RowCounter, 6) = wsSrc.Cells(rw.Row, 5)
    wsDest.Cells(RowCounter, 7) = wsSrc.Cells(rw.Row, 6)
    wsDest.Cells(RowCounter, 8) = wsSrc.Cells(rw.Row, 7)
    wsDest.Cells(RowCounter, 9) = wsSrc.Cells(rw.Row, 8)
    RowCounter = RowCounter + 1
Next rw

End Sub

Function FindAll(What, _
Optional SearchWhat As Variant, _
Optional LookIn, _
Optional LookAt, _
Optional SearchOrder, _
Optional SearchDirection As XlSearchDirection = xlNext, _
Optional MatchCase As Boolean = False, _
Optional MatchByte, _
Optional SearchFormat) As Range

'LookIn can be xlValues or xlFormulas, _
 LookAt can be xlWhole or xlPart, _
 SearchOrder can be xlByRows or xlByColumns, _
 SearchDirection can be xlNext, xlPrevious, _
 MatchCase, MatchByte, and SearchFormat can be True or False. _
 Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
 object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

Dim SrcRange As Range
If IsMissing(SearchWhat) Then
    Set SrcRange = ActiveSheet.UsedRange
ElseIf TypeOf SearchWhat Is Range Then
    Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
ElseIf TypeOf SearchWhat Is Worksheet Then
    Set SrcRange = SearchWhat.UsedRange
Else: SrcRange = ActiveSheet.UsedRange
End If
If SrcRange Is Nothing Then Exit Function

'get the first matching cell in the range first
With SrcRange.Areas(SrcRange.Areas.Count)
    Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
End With

Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
    SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

If Not CurrRange Is Nothing Then
    Set FindAll = CurrRange
    Do
        Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
        If CurrRange Is Nothing Then Exit Do
        If Application.Intersect(FindAll, CurrRange) Is Nothing Then
            Set FindAll = Application.Union(FindAll, CurrRange)
        Else: Exit Do
        End If
    Loop
End If
End Function

Answer 1

这个简单的函数将返回一个数组，其中包含与搜索项匹配的所有单元格地址，或者您的案例中的日期。然后，您可以使用数组地址执行您需要对这些单元格执行的操作。试试＆＃34; testBelow＆＃34;测试功能的程序。使用日期填写工作表范围，并使用该功能在工作表中查找该日期的所有实例。

Sub testBelow()
Dim myArray1() As Variant

myArray1 = findInMultipleColumns(DateValue("02/21/2017"), Sheet1.Range("A1:H50"))

If myArray1(1) = "" Then
    Beep
    MsgBox "Match not found"
    Exit Sub
End If

For i = LBound(myArray1) To UBound(myArray1)
    Debug.Print myArray1(i)
Next i

End Sub

Public Function findInMultipleColumns(searchTerm As String, searchRng As Range) As Variant()

Dim myArray() As Variant, arrayCounter As Long

ReDim myArray(1 To 1)
arrayCounter = 1

With searchRng
    Set c = .Find(searchTerm, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
            ReDim Preserve myArray(1 To arrayCounter)
            myArray(arrayCounter) = Replace(c.Address, "$", "")
            arrayCounter = arrayCounter + 1
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With

findInMultipleColumns = myArray
End Function

我尝试使用日期范围进行搜索，并将数据复制到新目的地

1 个答案: