Please help. I can not figure out how to get this to only search columns B and J exclusively. It is searching the range B:B through J:J. Everything else works fine.
Sub Find_Item(SNfound, SNRng, IDFound)
'The user is prompted to input either a serial number or unique ID number into a textbox on a userform.
'This is suppose to search only columns B (serial number) and J (ID number) in Table2 for the number the user entered
'Everything works except it is not limiting the search to only columns B and J. It is searching all columns from B through J.
Dim FindSNID As String
'note -- SNfound and IDFound are Dim As Boolean, SNRng is Dim As Range
Call ResetFilters 'this sub removes all filtering from the active sheet
FindSNID = SNID_textbox.Value
If Trim(FindSNID) <> "" Then
With Sheets("Inventory").Range("B:B", "J:J")
Set SNRng = .Find(What:=FindSNID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not SNRng Is Nothing Then
SNRng.Activate
'If a match was found in column B (serial number) then display a MsgBox that the item was found and it's self location is xxxxxx from column W (offset 0,21)_
'and it's current status is either available or checked out (offset 0,23)
If SNRng.Column = 2 Then
MsgBox "A matching serial number was found in location " & SNRng.Offset(0, 21).Value & vbCrLf & _
"It's current status is " & SNRng.Offset(0, 23).Value
Areabox2.Value = SNRng.Offset(0, 28).Value
Sectionbox2.Value = SNRng.Offset(0, 29).Value
Shelfbox2.Value = SNRng.Offset(0, 30).Value
SNfound = True
IDFound = False
End If
'If a match is found in column J (ID Number)then the item's shelf location and status is displayed.
If SNRng.Column = 10 Then
MsgBox "A matching ID number was found in location " & SNRng.Offset(0, 13).Value & vbCrLf & _
"It's current status is " & SNRng.Offset(0, 15).Value
Areabox2.Value = SNRng.Offset(0, 28).Value
Sectionbox2.Value = SNRng.Offset(0, 29).Value
Shelfbox2.Value = SNRng.Offset(0, 30).Value
SNfound = False
IDFound = True
End If
End If
End With
End If
End Sub
Try creating the range by setting a range variable = Union(Range("B:B"), Range("J:J"))
I finally figured out how to get the Union method to work.
I changed this:
Set SNRng = .Find(What:=FindSNID, _
To this:
Set SNRng = Union(Range("B:B"), Range("J:J")).Find(What:=FindSNID, _
Now the search only searches columns B and J.
Related
This is my first time using VBA and macros in excel, or excel really for that matter. I appreciate any help or insight that you could give me, ranging from what functions to loops can help me succeed in this task
I am trying to get this workbook set up from this:
Sample Work Book
I get a list that has to be reordered in order to import into another system. My task list is as follows for a macro:
Names and companies have to be merged into one, if there is a different name of a person, that must be concatenated. There will not be two different companies per company header.
Every File ID per company must be concatenated
Individual fees must be replaced with total fee per company.
Sorted by internal ID #, A-Z
Only one header on the new sheet
To look like this:
Target Work Book
My code below runs this: Current Progress
Sub format()
Application.ScreenUpdating = False
'This is the setup to get rid of unnecessary cells'
Dim rCell As Range
Dim cRow As Long, LastRow As Long
LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
'''Delete Merged Cells'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Company Name:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
'''Delete Headings'''
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*File #*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
''' Delete Sub Total"""
With Worksheets("Sheet1").Range("A1", Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp))
Do
Set c = .Find(What:="*Sub Total:*", After:=[A1], LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
cRow = c.Row
c.EntireRow.Delete
End If
Loop While Not c Is Nothing And cRow < LastRow
End With
End Sub
Again, I appreciate any help on this matter. Thank you!
There are a lot of ways to loop through the cells.
I picked column D with the company name as it didn't have too much clutter.
It's usually good to find the last row, to not loop through cells that we don't need. THere is a lot of ways for doing so as well. Today we'll go with Range("D" & .Rows.Count).End(xlUp).Row.
For the loop, we can use the For next approach, example:
For i = 1 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).Row
If Not Cells(i, 4).Value = "" Then
Next i
But this time, I went with the For Each, because I think it's a bit more readable.
Sub groupingEach()
Dim entry As Variant, prev As String, lRow As Long, lRow2 As Long
Dim inSht As Worksheet, outSht As Worksheet
Set inSht = Sheets(1)
Set outSht = Sheets(2)
lRow = inSht.Range("D" & inSht.Rows.Count).End(xlUp).Row 'last row
For Each entry In inSht.Range("D1:D" & lRow) 'loop 1st sheet
lRow2 = outSht.Range("D" & outSht.Rows.Count).End(xlUp).Row 'last row in output
If entry = prev And Not entry = "" Then
'-Group'
If InStr(outSht.Cells(lRow2, 3), entry.Offset(, 1)) = 0 Then 'does name exist?
outSht.Cells(lRow2, 3) = outSht.Cells(lRow2, 3) & vbNewLine & entry.Offset(, 1)
End If
outSht.Cells(lRow2, 5) = outSht.Cells(lRow2, 5) & vbNewLine & entry.Offset(, -2)
outSht.Cells(lRow2, 6) = outSht.Cells(lRow2, 6) + entry.Offset(, 2)
ElseIf Not entry = prev And Not entry = "" And Not entry = "Company" Then
'-New row
prev = entry 'Save company name for comparison
outSht.Cells(lRow2 + 1, 1) = entry.Offset(, -3)
outSht.Cells(lRow2 + 1, 2) = "Payable" 'Where to get this value?
outSht.Cells(lRow2 + 1, 3) = entry.Offset(, 1)
outSht.Cells(lRow2 + 1, 4) = entry
outSht.Cells(lRow2 + 1, 5) = entry.Offset(, -2)
outSht.Cells(lRow2 + 1, 6) = entry.Offset(, 2)
End If
Next entry
outSht.Cells(lRow2 + 3, 1).Value = "Grand Total:"
outSht.Cells(lRow2 + 3, 2).Formula = "=SUM(F:F)"
End Sub
From the examples, this should handle the document all the way from the Sample to the target. I wanted to loop the value copying, but the change in column order made it annoying.
I have one column with the names (First Name, Last Name) but sometimes there are the certificates, grades etc added to the names (ex: "John Smiths MBA"; "Susan Smiths FCA, ACCA"). The number of variable is countless but I identified the most common (there are many). Please help how to build the macro to clean this?
I've been using one by one, with:
Selection.Replace What:=" FCA,", Replacement:=" ", LookAt:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=True, _
ReplaceFormat:=False
But I guess there must be more efficient way to build this macro (and edit in case when new "unwanted extension is spotted).
Try this code
Sub Test()
Dim e, a, i As Long
Application.ScreenUpdating = False
For Each e In Array("MBA", "FCA", "ACCA", ", ")
Columns(1).Replace e, "", 2
Next e
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
.Value = Evaluate(Replace("IF(COLUMN(#)=1,TRIM(#),TRIM(PROPER(#)))", "#", .Address))
End With
Application.ScreenUpdating = True
End Sub
I assume all the certificates and grades are 3 to 4 letters at the end of names, and it's all in UPPER case. Try the code based on this scenario.
Sub Test()
Dim name As String
i = 2
name = Range("A" & i).Value
While name <> ""
If Right(name, 4) = UCase(Right(name, 4)) Then
Range("A" & i).Value = Left(name, Len(name) - 4)
ElseIf Right(name, 3) = UCase(Right(name, 3)) Then
Range("A" & i).Value = Left(name, Len(name) - 3)
End If
i = i + 1
name = Range("A" & i).Value
Wend
End Sub
I have 2 Excel Files
Tracker
**Grp** **Current Status** **Prior Status** **Any Changes**
grp1 Implementation Approved Change
grp2 Approved Approved No Change
grp3 Doc Recd Doc Recd No Change
grp4 Implementation Approved Change
Inventory
**Grp** **Current Status** **Col02**
grp1 Approved 789
grp2 Approved 123
grp3 Doc Recd 456
grp4 Approved 000
I am very new to VBA , I am not sure how to write a query , so approaching the community for help .
In Trackers file if Grp has different values in status and Prior Status then Any Changes will be considered as change.
If Current Status & Prior Status are same it will be considered as No Change
for below example grp1 & grp4 Current Status has changed from Prior Status
I just want code :
That Checks Change in Any Changes column "If Change"
Then grp1 & grp4 Current Status from Tracker file should be updated in Inventory file Current Status column based on the Group Name.
Note: Sometimes there might be extra spaces between the both file grp field.
I do this manually and update records from Tracker to Inventory everyday.
VBA Code should activate respective files and columns and change values.
Code i tried didn't work attaching below
Sub Lookup()
Dim rnge as Range
Dim cl As Range
Workbooks("Trackers 040620 PM.xlsx").Activate
Worksheets("Central").Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Range("g" & i).Value = "Change" Then
srchval = Trim(Range("d" & i).Value)
chgval = Trim(Range("e" & i).Value)
Workbooks("Interim Inventory Tracker - All States 040620 v1.xlsx").Activate
Sheets("Main Data input").Activate
get_row_number = Workbooks("Interim Inventory Tracker - All States 040620 v1.xlsx"). _
Sheets("Main Data input").Range("D:D").Find( _
What:=srchval, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True _
).Row
If get_row_number = "" Then
'do nothing
Else
Workbooks("Interim Inventory Tracker - All States 040620 v1.xlsx").Activate
Sheets("Main Data input").Range("H" & get_row_number).Value = chgval
chgval = ""
End If
Workbooks("Trackers 040620 PM.xlsx").Activate
Worksheets("Central").Activate
End If
Next i
End Sub
Try
Option Explicit
Sub Lookup()
Const WB_TRACKER = "Trackers 040620 PM.xlsx"
Const WB_INVENTORY = "Interim Inventory Tracker - All States 040620 v1.xlsx"
Dim wbTracker As Workbook, wsTracker As Worksheet
Dim wbInventory As Workbook, wsInventory As Worksheet
Dim rng As Range
Dim iLastRow As Long, iRow As Long, count As Long
Dim srchval As String, chgval As String
Set wbTracker = Workbooks(WB_TRACKER)
Set wsTracker = wbTracker.Sheets("Central")
Set wbInventory = Workbooks(WB_INVENTORY)
Set wsInventory = wbInventory.Sheets("Main Data input")
iLastRow = wsTracker.Range("G" & Rows.count).End(xlUp).Row
count = 0
For iRow = 2 To iLastRow
If wsTracker.Range("G" & iRow).Value = "Change" Then
srchval = Trim(wsTracker.Range("D" & iRow).Value)
chgval = Trim(wsTracker.Range("E" & iRow).Value)
Set rng = wsInventory.Range("D:D").Find( _
What:=srchval, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True)
If rng Is Nothing Then
'do nothing
Else
wsInventory.Range("H" & rng.Row) = chgval
count = count + 1
End If
End If
Next
MsgBox iLastRow - 1 & " rows scanned on " & wsTracker.Name & vbCr & _
count & " rows updated on " & wsInventory.Name, vbInformation
End Sub
There is a list of ID's with their chosen subjects in their respective row. I am trying to write code that will read through the subjects, and ensure that any two out of a selected four of the subjects are chosen (out of 15 subjects), and if it isn't be reported back as an error. The subjects needed are either SBC130, SBC150, SBC210 or SBC220, and any combination of the 2 are good out of a range of 15 possible subjects.
This is the code I have so far
Dim programme, module, ID As String
Dim rng As Range
Dim a, b, c, d As Variant
lastidno = Range("A2", Range("A2").End(xlDown)).Count
For i = 2 To lastidno
Sheets("Part B + C Modules").Activate
Set rng = Range("C" & i, Range("C" & i).End(xlToRight))
For j = 1 To 4
Set a = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC130", LookIn:=xlValues, lookat:=xlWhole)
Set b = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC150", LookIn:=xlValues, lookat:=xlWhole)
Set c = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC210", LookIn:=xlValues, lookat:=xlWhole)
Set d = Range("C" & j, Range("C" & j).End(xlToRight)).Find("SBC220", LookIn:=xlValues, lookat:=xlWhole)
If a Is Nothing And b Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 1"
ElseIf a Is Nothing And c Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 2"
ElseIf a Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 3"
ElseIf b Is Nothing And c Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 4"
ElseIf b Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 5"
ElseIf c Is Nothing And d Is Nothing Then
Sheets("Available sub").Activate
Range("F" & i) = "Incorrect 6"
End If
Next
Next
Please share your thoughts on what the relevant steps are to complete this! Thanks in advance!
Here's a generic function that will check a range against a list of values and determine if the quantity of unique values from the provided list is greater than or equal to a desired threshold:
Function CheckUnqValueQty(ByVal arg_rData As Range, ByVal arg_lThreshold As Long, ByVal arg_aValues As Variant) As Boolean
'This gets the number of unique values listed in arg_aValues found in the arg_rData range
Dim lEvalResult As Long
On Error Resume Next 'Suppress errors if any of the arguments were supplied incorrectly or if any of the data cells contain error values
lEvalResult = Evaluate("SUMPRODUCT(--(COUNTIF(" & arg_rData.Address(External:=True) & ",{""" & Join(arg_aValues, """,""") & """})>0))")
On Error GoTo 0 'Remove the "On Error Resume Next" condition (no longer suppress errors); if there was an error, lEvalResult will be 0
'If the eval result is >= the threshold then return True, else False
CheckUnqValueQty = (lEvalResult >= arg_lThreshold)
End Function
And then you'd call that function from within your loop, like so:
Sub tgr()
'Define the list of subjects
Dim aSubjects() As Variant
aSubjects = Array("SBC130", "SBC150", "SBC210", "SBC220")
'Define the valid threshold
Dim lValidQty As Long
lValidQty = 2
'Make sure we're working with the correct worksheet
With ActiveWorkbook.Worksheets("Part B + C Modules")
'Initiate the loop starting at row 2 and going to last used row
Dim i As Long
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
'Define the range to check
Dim rCheck As Range
Set rCheck = .Range(.Cells(i, "C"), .Cells(i, .Columns.Count).End(xlToLeft))
'Call the function to check if the appropriate number of different subjects have been selected
If CheckUnqValueQty(rCheck, lValidQty, aSubjects) = True Then
'valid result, 2 or more different required subjects selected
'do something for a valid result here
Else
'invalid result, 0 or 1 required subjects selected
ActiveWorkbook.Worksheets("Available sub").Cells(i, "F").Value = "Incorrect"
End If
Next i
End With
End Sub
If a formula works:
=IF(AND(B1<>B2,COUNTIF(C1:C4,B1)+COUNTIF(C1:C4,B2)=2),"OK","Incorrect")
For some VBA, maybe something like this:
Dim tempstring As String
With Sheets("unknown")
tempstring = .Range("C1").Value & "|" & .Range("C2").Value & "|" & .Range("C3").Value & "|" & .Range("C4").Value
If InStr(tempstring, .Range("B1").Value) > 0 And InStr(tempstring, .Range("B2").Value) > 0 Then
Sheets("Available sub").Range("F1") = "OK"
Else
Sheets("Available sub").Range("F1") = "Incorrect"
End If
End With
Note that you don't qualify the sheets for all you ranges so I used a sheet called "unknown", adjust the code to match you workbook
If your Student ID numbers are in column B (change column as needed) you could loop through each Student ID, and Count the number of cells with constants in the range for each row. Your notification can be a message box or color the Student ID interior color red, with this basic macro.
For Each cel In ActiveSheet.Range("B2", Range("B" & Rows.Count).End(xlUp))
If cel.Resize(, 4).Offset(, 1).SpecialCells(xlCellTypeConstants).Count < 2 Then
MsgBox "Student " & cel.Text & "did not select two subjects"
'Or
cel.Interior.Color = RGB(256, 0, 0)
End If
Next cel
My issue is that I am trying to extract some information from a very large data sheet. The information that is being extracted is based on some search criteria that is entered on a form. The search form counts how many occurrences of this criteria exist, but then I need to extract the individual rows into a second sheet.
The bit I'm having difficulty with is understanding how to actually structure the extraction code. I'm in need of being pointed in the right direction. If the code can count how many occurrences there are, surely I can get the row numbers for those occurrences and extract the information, I'm just not getting anywhere trying to figure it out.
Here's my SEARCH code (this code works to get the number of occurrences based on the criteria asked)
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
Is there an easy way of doing this with a loop? I know loops are not the best way of handling things, but Im looking for anything that works and I can tweak to suit my needs.
Thanks if you can help in advance, it's a monster of a spreadsheet!
----------------------------
*Update With Accepted Answer:*
----------------------------
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
You should be able to set a For loop to check each value in the range you've found and copy it to (another cell, an array, whatever you like.)
For i = rowNum To rowNumEnd
If Cells(i,CR1).Value = V_1 Then
MsgBox "Found match on row " & i
End If
Next i
I haven't tested this, but it should work. Let me know if you get any errors.
I can't really try this out, but maybe you can. Keep the line V_1 = Me.Criteria_1_Variable.Value but replace the next 2 by :
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!
You can then loop through that array with this code :
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 : I just read that the spreadsheet is monstruous, and re-dimensioning every time a new match is found might be neat, but it's a hell of a performance drop. I made some changes directly in the above code to make it somewhat more effective.
EDIT #2 : I've simplified code so you don't have anything to do but a copy paste (please forgive me not assuming RowNum and RowNumEnd had valid data). It should work exactly as accepted answer, but was posted a bit before and actually shows how to extract the line number. I understand if all you needed is a pop-up box with the line number, and will be satisfied with the upvote already received.