Извлечение строк на основе критериев поиска

Question

Моя проблема заключается в том, что я пытаюсь извлечь некоторую информацию из очень большой спецификации. Информация, которая извлекается, основана на некоторых критериях поиска, которые вводятся в форме. Форма поиска подсчитывает, сколько существует значений этого критерия, но тогда мне нужно извлечь отдельные строки во второй лист.

У меня с трудом возникает вопрос, как на самом деле структурировать код извлечения. Я нуждаюсь в том, чтобы быть направленным в правильном направлении. Если код может подсчитать количество вхождений, конечно, я могу получить номера строк для этих вхождений и извлечь информацию, я просто не получаю нигде, пытаясь понять это.

Вот мой код ПОИСКА (этот код работает, чтобы получить число появлений на основе критериев, просили)

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 

есть простой способ сделать это с петлей? Я знаю, что петли - не лучший способ справиться с вещами, но Im ищет все, что работает, и я могу настроить в соответствии с моими потребностями.

Спасибо, если вы можете помочь заранее, это монстр электронной таблицы!

---------------------------- * Обновление с Accepted Ответ: * ---- ------------------------

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 i = rowNum To rowNumEnd 
    If Cells(i,CR1).Value = V_1 Then 
     MsgBox "Found match on row " & i 
    End If 
Next i 

убежища I» t проверил это, но он должен работать. Дайте мне знать, если вы получите какие-либо ошибки.

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 

EDIT: Я только что прочитал, что электронная таблица чудовищная, и переизмерение каждый раз, когда новое совпадение найдено, может быть аккуратным, но это черта падения производительности. Я сделал некоторые изменения непосредственно в приведенном выше коде, чтобы сделать его несколько более эффективным.

EDIT # 2: У меня есть упрощенный код, поэтому вам нечего делать, кроме как скопировать пасту (прошу простить меня, если вы не предполагаете, что RowNum и RowNumEnd имеют действительные данные). Он должен работать точно так же, как принятый ответ, но был опубликован немного раньше и фактически показывает, как извлечь номер строки. Я понимаю, что все, что вам нужно, это всплывающее окно с номером строки и будет удовлетворено уже полученным upvote.