Question

我的问题是我试图从非常大的数据表中提取一些信息。正在提取的信息基于在表单上输入的某些搜索条件。搜索表单计算存在此条件的出现次数，但之后我需要将各个行提取到第二个表格中。

我遇到困难的一点是理解如何实际构造提取代码。我需要指向正确的方向。如果代码可以计算出有多少次出现，那么我肯定可以得到这些事件的行号并提取信息，我只是没有试图找出它。

这是我的SEARCH代码（此代码工作可根据要求的条件获取出现次数）

Public Sub Run_Count_Click()

'// Set Ranges
Dim Cr_1, CR1_range, _
Cr_2, CR2_range, _
Cr_3, CR3_range, _
Cr_4, CR4_range, _
Cr_5, CR5_range _
As Range

'// Set Integers
Dim CR1, V1, CR1_Result, _
CR2, V2, CR2_Result, _
CR3, V3, CR3_Result, _
CR4, V4, CR4_Result, _
CR5, V5, CR5_Result, _
total_result, _
total_result2, _
total_result3, _
total_result4, _
total_result5 _
As Integer

'Set Strings
Dim V_1, V_2, V_3, V_4, V_5 As String

Dim ws As Worksheet

Set ws = Worksheets("database")

Sheets("Settings").Range("Start_Date").Value = Format(Me.R_Start.Value, "mm/dd/yyyy")
Sheets("Settings").Range("End_Date").Value = Format(Me.R_End.Value, "mm/dd/yyyy")

'Collect Start & End Dates
Dim dStartDate As Long
Dim dEndDate As Long
dStartDate = Sheets("Settings").Range("Start_Date").Value
dEndDate = Sheets("Settings").Range("End_Date").Value

ws.Activate

On Error GoTo error_Sdate:
Dim RowNum As Variant
    RowNum = Application.WorksheetFunction.Match(dStartDate, Range("B1:B60000"), 0)
     'MsgBox "Found " & Format(dStartDate, "dd/mm/yyyy") & " at row : " & RowNum

On Error GoTo error_Edate:
Dim RowNumEnd As Variant
    RowNumEnd = Application.WorksheetFunction.Match(dEndDate, Range("B1:B60000"), 1)
    ' MsgBox "Found " & Format(dEndDate, "dd/mm/yyyy") & " at row : " & RowNumEnd

GoTo J1

error_Sdate:

Dim msg As String

msg = "You entered " & Format(dStartDate, "dd/mm/yyyy") & " as your Start Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the Start Date box"
MsgBox msg, , "Start Date Not Found"
Err.Clear
Exit Sub

error_Edate:
msg = "You entered " & Format(dEndDate, "dd/mm/yyyy") & " as your End Date, but no referrals were made on that date"
msg = msg & vbCrLf & "Please enter a different date in the End Date box"
MsgBox msg, , "End Date Not Found"
Err.Clear
Exit Sub


J1:


'// Get Criteria From Form And Search Database Headers
Set Cr_1 = ws.Cells.Find(What:=Me.Count_Criteria_1.Value, After:=ws.Cells(1, 1), MatchCase:=False)

If Not Cr_1 Is Nothing Then

CR1 = Cr_1.Column '//Set CR1 as the Column in which the Criteria Header was found

Else
    MsgBox "Criteria 1 Has Not Been Found In The Database. Report Has Failed To Generate"
    Exit Sub
End If

'// Get Variable Value From Form And Set Shortcode
V_1 = Me.Criteria_1_Variable.Value

Set CR1_range = ws.Range(ws.Cells(RowNum, CR1), ws.Cells(RowNumEnd, CR1))
CR1_Result = Application.CountIf(CR1_range, V_1)

Me.Count_Result.visible = True

Me.Count_Result.Value = "Based On Your Search Criteria Of:" & vbNewLine & vbNewLine & _
"- " & Me.Count_Criteria_1.Value & ": " & Me.Criteria_1_Variable.Value & vbNewLine & vbNewLine & _
"The Results Are: " & CR1_Result & " entries found between the dates " & Format(dStartDate, "dd/mm/yyyy") & _
" and " & Format(dEndDate, "dd/mm/yyyy")





Exit Sub

使用循环有一种简单的方法吗？我知道循环不是处理事物的最佳方式，但我正在寻找有用的东西，我可以调整以满足我的需求。

如果您可以提前提供帮助，那就谢谢它，它是电子表格中的怪物！

---------------------------- * 以接受的答案更新： * 的 ----------------------------

Public Sub Count_Extract_Click()

'Collect Information To Be Extracted
Set ws = Worksheets("database")
Set ps = Worksheets("Extracted Rows")

   ps.Range("A3:AM60000").Clear


For i = RowNum To RowNumEnd
   If ws.Cells(i, CR1).Value = V_1 Then

   ws.Range("A" & i & ":AM" & i).Copy

   ps.Activate


   'find first empty row in database
emR = ps.Cells.Find(What:="*", SearchOrder:=xlRows, _
    SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1


ps.Range("A" & emR & ":AM" & emR).PasteSpecial

   End If
Next i

End If

End Sub

Answer 1

你应该能够设置一个For循环来检查你找到的范围内的每个值并将其复制到（另一个单元格，一个数组，无论你喜欢什么。）

For i = rowNum To rowNumEnd
   If Cells(i,CR1).Value = V_1 Then
      MsgBox "Found match on row " & i
   End If
Next i

我没有对此进行测试，但它应该可行。如果您有任何错误，请告诉我。

Answer 2

我无法真正尝试这一点，但也许你可以。保持行V_1 = Me.Criteria_1_Variable.Value，但将下一个2替换为：

CR1_Result = 0 'Initiates counter at 0
Dim CR1_Lines(1000) As Long 'Declares an array of 1001 (indexes 0-1000) Longs (big integers) 

For x = RowNum To RowNumEnd 'Loops through all the rows of CR1

    If ws.Cells(x, CR1) = V_1 Then 'Match!

        'Double array size if capacity is reached
        If CR1_Result = UBound(CR1_Lines) Then
            ReDim Presrve CR1_Lines(UBound(CR1_Lines) * 2)
        End If

        'Store that line number in the array
        CR1_Lines(CR1_Result) = x 

        'Increment count of matches
        CR1_Result = CR1_Result + 1 

    End If

Next x 'Next row!

然后，您可以使用以下代码遍历该数组：

For i = 0 to UBound(CR1_Lines)
    'Do something! (Why not just an annoying pop-up box with the content!)
     MsgBox CR1_Lines(i)
Next i

编辑：我刚刚看到电子表格是一个单调的，每次找到新匹配时重新标注尺寸可能很整洁，但这是一个性能下降的地狱。我在上面的代码中直接进行了一些更改，以使其更有效。

编辑＃2：我简化了代码，因此除了复制粘贴之外你没有任何事情要做（请原谅我不要假设RowNum和RowNumEnd有有效数据）。它应该完全按照接受的答案工作，但之前发布了一点，实际上显示了如何提取行号。我知道如果你需要的只是一个带行号的弹出框，并且对已经收到的upvote感到满意。

基于搜索标准提取行

2 个答案: