I have been working on this program that...
Finds a five-digit code in a workbook
Looks in a second workbook to find a matching code
Copies a set of corresponding data from the first workbook onto the second.
It works for the most part, but when there is a value that is present on the first book but not the second it fails. If I let it run the values get messed up, but the program does complete. I need to find a way to recognize an error, which would be foundItem = 0, and then restart the loop from that point so nothing gets copied. I appreciate the help.
Sub findExample()
On Error Resume Next
Dim foundItem As Range
Dim codeValue As String
Dim strAddress As String
Dim endOfWorksheet As Boolean
Dim x As Long
x = 1
Do While endOfWorksheet = False
x = x + 1
Sheets("Medex Center Master List").Select
Dim NRange As String
NRange = "N" + CStr(x)
codeValue = Range(NRange, NRange).Value
Sheets("6035P_ATRSDeviceListII").Select
Set foundItem = Range("M1:M300").Find(codeValue)
Dim col
Dim rowa
col = Split(foundItem.Address, "$")(1)
rowa = Split(foundItem.Address, "$")(2)
strAdress = col + rowa
Dim FRange As String
FRange = "A" + CStr(x) + ":" + "M" + CStr(x)
Sheets("Medex Center Master List").Range(FRange).Copy Sheets("6035P_ATRSDeviceListII").Range(strAdress).Offset(0, 1)
If x = 265 Then
endOfWorksheet = True
End If
Loop
MsgBox "program completed"
End Sub
Thanks Again,
Samuel
As mentioned in comments but with more detail:
Remove the On Error Resume Next. It is just hiding any errors that are occurring.
Your code could be simplified and improved in the following manner:
Use a regular For...Next loop.
Avoid using Select.
Specify more parameters of Range.Find, specifically LookIn and LookAt.
Test if the Find succeeded using If Not ... Is Nothing Then.
Sub FindExample()
Dim i As Long
For i = 1 to 265
Dim masterWs As Worksheet
Set masterWs = ThisWorkbook.Worksheets("Medex Center Master List")
Dim codeValue As String
codeValue = masterWs.Range("N" & i).Value
Dim deviceListWs As Worksheet
Set deviceListWs = ThisWorkbook.Worksheets("6035P_ATRSDeviceListII")
Dim foundItem As Range
Set foundItem = deviceListWs.Range("M1:M300").Find( _
What:=codeValue, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundItem Is Nothing Then
masterWs.Range("A" & i & ":M" & i).Copy _
Destination:=foundItem.Offset(0,1)
End If
Next
End Sub
Related
I'm trying to do a simple thing. The code is supposed to copy specific ranges from one workbook to another but when I run the following code copying doesn't occur - nothing happens. (copying happens in the last part of Sub). I suspect it might be a problem with worksheets/workbooks but I'm really new into VBA so it's hard to say for me...
Function getHeaderRange(searched As String, ws As Worksheet) As Range
Dim colNum
Dim cellLength
colNum = WorksheetFunction.Match(searched, ws.Range("5:5"))
cellLength = ws.Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
Set getHeaderRange = Range(ws.Cells(6, colNum), ws.Cells(6, colNum + cellLength - 1))
End Function
Function getDataRange(searched As String, hRange As Range) As Range
Dim column: column = WorksheetFunction.Match(searched, hRange) + hRange.column - 1
Set getDataRange = Range(Cells(6, column), Cells(6, column))
Debug.Print (hRange.Worksheet.Parent.Name & "Sheet: " & hRange.Worksheet.Name)
Set getDataRange = getDataRange.Offset(1, 0)
Set getDataRange = getDataRange.Resize(8)
End Function
Sub main()
Dim srcWs As Worksheet: Set srcWs = Workbooks("Period end open receivables, step 5").Sheets(1)
Dim trgWs As Worksheet: Set trgWs = ThisWorkbook.Sheets("Obiee")
Dim searched As String
Dim hSearched As String
searched = "Magazines, Merchants & Office"
Dim srcRange As Range: Set srcRange = getHeaderRange(searched, srcWs)
Dim trgRange As Range: Set trgRange = getHeaderRange(searched, trgWs)
Dim cocd() As Variant
Dim i As Integer
cocd = getHeaderRange("Magazines, Merchants & Office", trgWs)
For i = 1 To UBound(cocd, 2)
hSearched = cocd(1, i)
getDataRange(hSearched, srcRange).Copy
getDataRange(hSearched, trgRange).PasteSpecial xlPasteValues
Next i
End Sub
When I change last lines to:
For i = 1 To UBound(cocd, 2)
hSearched = cocd(1, i)
srcWs.Activate
getDataRange(hSearched, srcRange).Copy
trgWs.Activate
getDataRange(hSearched, trgRange).Select
ActiveSheet.Paste
Next i
It works just fine but I really would like to avoid this approach and find out what's wrong with the first one. Help really appreciated!
Edit: I'm including a to screenshots of workbooks (1. srcWb, 2. trgWb)
The file is huge and differentiated but in this cut they are the tables are the same.
Your ranges aren't fully qualified..
When they're not qualified, Excel will guess which worksheet the range in question resides on, usually using the currently active worksheet. That's why your workaround works as you change the active worksheet.
This line needs to be fully qualified:
cellLength = Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
So it'll become:
Function getHeaderRange(searched As String, ws As Worksheet) As Range
Dim colNum
Dim cellLength
colNum = WorksheetFunction.Match(searched, ws.Range("5:5"))
cellLength = ws.Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
Set getHeaderRange = ws.Range(ws.Cells(6, colNum), ws.Cells(6, colNum + cellLength - 1))
End Function
Also, this line is not qualified at all:
Set getDataRange = Range(Cells(6, column), Cells(6, column))
So it'll become:
Function getDataRange(searched As String, hRange As Range) As Range
Dim column: column = WorksheetFunction.Match(searched, hRange) + hRange.column - 1
Dim ws As Worksheet: Set ws = hRange.Worksheet
Set getDataRange = ws.Range(ws.Cells(6, column), ws.Cells(6, column))
Debug.Print (ws.Parent.Name & "Sheet: " & ws.Name)
Set getDataRange = getDataRange.Offset(1, 0)
Set getDataRange = getDataRange.Resize(8)
End Function
As per my comment below, to radically speed things up, I'd recommend removing these two lines from Main():
getDataRange(hSearched, srcRange).Copy
getDataRange(hSearched, trgRange).PasteSpecial xlPasteValues
and replacing them with:
getDataRange(hSearched, trgRange).Value = getDataRange(hSearched, srcRange).Value
i am working on the exercise below but i need some help. It is giving runtime error 13. I am a beginner, can you please help me solve it? Of course other ways of solving the problem are more than welcomed. There are 2 lists (1: Sheet2.Range("E5:E1324") and 2:SearchRange = Sheet1.Range("F2:F4178"))
, of long text format and not exact match, list 1 contains a phrase of the information in list2. I need to know how many times data in list 2 is mentioned in list 1 (as i know there are times it goes up to 7)
Thank you a lot,
Ana
Sub countvalues()
' count how many times data in Description Range is listed in SearchRange
Dim i As Integer 'for looping in Description
Dim j As Integer 'for looping in SearchRange
Dim Counter As Integer
Dim FoundData As Range
Dim Description As Range
Dim SearchRange As Range
Set Description = Sheet2.Range("E5:E1324")
Set SearchRange = Sheet1.Range("F2:F4178")
Application.ScreenUpdating = False
Counter = 0
For i = 5 To 1324 'trying with a narrower range for testing purpose
For j = 2 To 4178
Set FoundData = SearchRange.Find(Sheet2.Range("E" & i))
'On Error Resume Next
Counter = FoundData.Count + 1
Next j
Sheet2.Range("F" & i) = Counter
Next i
Application.ScreenUpdating = True
End Sub
Try the adapted code, please. It will work only if your string used for search (What) is contained in the searched range cells... I mean "test searched" will be found in "test searched today". But "test searched today" will not be found in "test searched"
Sub testFindSimilar()
Dim d As Long, strFirstAddress As String
Dim Counter As Long, lastR1 As Long, lastR2 As Long
Dim shD As Worksheet, shS As Worksheet, cel As Range
Set shD = sheet1
Set shS = sheet2
lastR1 = shS.Range("F" & Rows.Count).End(xlUp).Row
lastR2 = shD.Range("E" & Rows.Count).End(xlUp).Row
For d = 5 To lastR2
Set cel = shS.Range("F2:F" & lastR1).Find(What:=shD.Range("E" & d).value, _
After:=shS.Range("F2"), LookIn:=xlValues, SearchOrder:=xlByRows, LookAt:=xlPart)
If Not cel Is Nothing Then
strFirstAddress = cel.Address
Do
Set cel = shS.Range("F2:F" & lastR1).FindNext(cel)
If Not cel Is Nothing Then
Counter = Counter + 1
End If
Loop Until cel.Address = strFirstAddress
End If
shD.Range("F" & d).value = Counter
Counter = 0: strFirstAddress = ""
Next d
End Sub
If you wont to test less rows, you can replace last rows variable with your testing numbers.
I have an API call that pulls data relating to 34 individual sites. Each site has a varying number of assets within it, each with a unique identifier.
I am trying to write a macro that will copy and paste the data for specific sites into their own individual worksheet within the file. The basic concept of this I am familiar with but I am struggling with the ranges I need to specify.
So basically, I need the macro to work its way down Column A of the sheet called Raw Data and identify any rows where the Site name (Value in column A) matches one of the Sheet names. It should then copy the Rows from A to H with that site name and paste into the respective site sheet in rows A to H.
The values in Column A will always match one of the other sheets in the workbook.
Example image that might help explain a bit better:
Apologies in advance if my explanation is not very clear. I have very limited experience using macros so I am not sure if my way of explaining what I want to achieve is understandable or if at all possible.
I am very keen to learn however and any guidance you fine folk could offer would be very much appreciated.
Welcome!
Try this one
Function ChkSheet(SheetName As String) As Boolean
For i = 1 To Worksheets.Count
If Worksheets(i).Name = SheetName Then
ChkSheet = True
Exit Function
End If
Next
ChkSheet = False
End Function
Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String
Set wsRaw = Worksheets("Raw Data")
For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
Aux = wsRaw.Cells(i, 1).Value2
k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
Else
Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
Aux = wsRaw.Cells(i, 1).Value2
k = 2
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
End If
Next
End Sub
So the Function ChkSheet will check if the sheet exist (you don´t need to create them) and the procedure test will follow all the items that you have in your "Raw Data" worksheet and it will copy to the last used row of every sheet.
And please, even for a newbie, google, read, get some information and when you get stacked, ask for help. This forum is not for giving solutions with not effort.
Good morning all,
David, thanks very much for your help with this. I really didn't want you to think I was trying to get someone to give me the answer and I had tried a few other things before asking the question, but I neglected to show any evidence of my workings. Rookie mistake and I apologise for this.
Having done a bit more research online and with a good dollop of help from a much more experienced colleague I have got the below code using advance filter which works perfectly for what I need.
I thought I would share it here in case it is of any use to others in the future.
Option Explicit
Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()
'Cell Address where RawData is pasted to each of the site sheets
RawDataCol = "A2"
'Column where the Unique List is cleared and pasted
ListCol = "L"
'Advanced Filter Range
AdvRng = "A1:K2"
'Pasted Raw Data Columns on each sheet
RawDataRng = "A2:K"
'Site Abr gets pasted to the address during loop
SiteAbrRng = "A2"
'Range that gets deleted after pasting Raw Data to each sheet
ShiftCols = "A2:K2"
End Sub
Sub CopyDataToSheets()
On Error GoTo ErrorHandler
AppSettings (True)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long
Set wbk = ThisWorkbook
SetParameters
Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_RawData = sht_RawData.ListObjects("_00")
'clear unqie list of SiteAbr
With sht_TurbineData
LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row
If LastRow1 > 1 Then
'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
End If
End With
'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
Unique:=True
LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row
'Sort Unique List
sht_TurbineData.Range("L1:L" & LastRow1).Sort _
Key1:=sht_TurbineData.Range("L1"), _
Order1:=xlAscending, _
Header:=xlYes
'Load unique site Abr to array
With sht_TurbineData
'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))
UniqueListCount = LastRow1 - 1
End With
'Test Array conditions for 0 items or 1 item
ArrTest = IsArray(MyArr)
If UniqueListCount = 1 Then
MyArr = Array(MyArr)
ElseIf UniqueListCount = 0 Then
GoTo ExitSub
End If
For x = LBound(MyArr) To UBound(MyArr)
Set sht_target = wbk.Worksheets(MyArr(x))
With sht_target
'Find the last non blank row of the target paste sheet
LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
'Clear contents if the Last Row is not the header row
If LastRow2 > 1 Then
.Range(RawDataRng & LastRow2).ClearContents
End If
sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)
'Filter Source Data and Copy to Target Sheet
tbl_RawData.Range.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
CopyToRange:=.Range(RawDataCol), _
Unique:=False
'Remove the first row as this contains the headers
.Range(ShiftCols).Delete xlShiftUp
End With
Next x
ExitSub:
SecondsElapsed = Round(Timer - StartTime, 3)
AppSettings (False)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
ErrorHandler:
MsgBox (Err.Number & vbNewLine & Err.Description)
GoTo ExitSub
End Sub
Sub ClearAllSheets()
Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long
Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")
SetParameters
MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)
For x = LBound(MyArray) To UBound(MyArray)
Set sht_target = wbk.Worksheets(MyArray(x))
LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
sht_target.Range("A2:K" & LastRow).ClearContents
End If
Next x
End Sub
Private Sub AppSettings(Opt As Boolean)
If Opt = True Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ElseIf Opt = False Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Thanks again to all who answered and especially to you David. Although I have only used the basic principles from what you offered, it was extremely useful to help me understand what I needed to do in order to get the data to copy into the correct sheets.
Many thanks,
MrChrisP
As the title says, match function taking too long. One spreadsheet is 100,000 rows long and it has a bunch of securities that i need to make sure are on another spreadsheet which has 800,000 rows. Below is the code:
FYI i am average in code building so i am pretty rudimentary in terms of laying out my arguments.
Option Explicit
'a lot of dims
StartTime = Timer
Set ShVar = ThisWorkbook.Worksheets("in1")
With wnewwqr
Set OutShVar = wnewwqr.Worksheets("First Sheet")
Set RngConcat = OutShVar.Range("B:B")
Set RngConcatISIN = OutShVar.Range("A:A")
Set OutShVar1 = wnewwqr.Worksheets("Second Sheet")
Set RngConcat1 = OutShVar1.Range("B:B")
Set RngConcatISIN1 = OutShVar1.Range("A:A")
End With
With ShVar
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
End With
For i = 2 To lastrow
With ShVar
If .Range("O" & i).Value = "" Then
.Range("P" & i & ":Q" & i).Value = "No Security" 'Checking for no securities
Else
If Not IsError(Application.Match(.Range("O" & i).Value, RngConcat, 0)) Then
.Range("P" & i).Value = "US" ' writing US when it finds a US security in the confidential workbook
Else
.Range("P" & i).Value = "Not a US Security"
End If
End If
If .Range("P" & i).Value = "Not a US Security" Then
If Not IsError(Application.Match(.Range("O" & i).Value, RngConcat1, 0)) Then 'Only searching for securities if the first vlookup resulted in nothing and then it would go into the second sheet
.Range("Q" & i).Value = "US"
Else
.Range("Q" & i).Value = .Range("P" & i).Value
End If
End If
End With
Next i
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Update:
I have turned everything to variant and now using find function but still not that fast as i would have hoped. Took 14 mins approx. to do a trial run of 2000 rows. And i have to do this on 90,000 rows
Option Explicit
Sub something
Dim lastrow As Long
Dim OutShVar As Worksheet
Dim ShVar As Worksheet
Dim WhatCell As Range
Dim i As Long
Dim TaskID As Variant
Dim confidentialfp As String
Dim confidential As String
Dim wconfidential As Workbook
Dim x As Variant
Set ShVar = ThisWorkbook.Worksheets("in1")
With ShVar
lastrow = .Cells(.Rows.Count, "H").End(xlUp).Row
End With
confidential = "confidential_2018-03-01 (Consolidated).xlsx"
Set wconfidential = Workbooks(confidential)
With wconfidential
Set OutShVar = .Worksheets("First Sheet")
End With
With ShVar
For i = 1 To lastrow
TaskID = ShVar.Range("O" & i).Value
Set x = .Range("A" & i)
Set WhatCell = OutShVar.Range("B:B").Find(TaskID, lookat:=xlWhole)
On Error Resume Next
x.Offset(0, 7).Value = WhatCell.Offset(0, 1)
Next i
End With
End Sub
I'm not sure you're quite getting ScottCraner's point. What he's saying is you should read all of your reference values (ie the big list of securities) into a couple of arrays, and you should write your output values to another array. You'd then write the entire output array to the sheet in one command.
It might also be worth you converting your list of securities to a Collection as that has a very fast 'look-up' capability. There'd be ways of making this much faster, for example by sorting the securities, but you'd need to get into some mathematics for that.
In the example below, this skeleton code shows how it might be done. You should be aware that I didn't bother splitting the two securities lists into two collections, so you'd want to do that yourself if you needed it. I've also put all my test sheets on the same workbook, so adjust the worksheet qualifiers as needed:
Option Explicit
Sub RunMe()
Dim securities As Collection
Dim testSheet As Worksheet
Dim testItems As Variant
Dim i As Long
Dim exists As Boolean
Dim output() As Variant
'Read the first list of securities into the collection.
PopulateColumnCollection _
ThisWorkbook.Worksheets("First Sheet"), _
"B", _
securities
'Read the second list of securities into the collection.
'I've used the same collection in this example, you'll need
'to create two if you want separate columns in your output.
PopulateColumnCollection _
ThisWorkbook.Worksheets("Second Sheet"), _
"B", _
securities
'Read the test items into an array.
Set testSheet = ThisWorkbook.Worksheets("in1")
With testSheet
testItems = RangeTo2DArray(.Range( _
.Cells(2, "O"), _
.Cells(.Rows.Count, "O").End(xlUp)))
End With
'Prepare your output array.
'I've just used one column for output. If you want two then
'you'll need to resize the second dimension.
ReDim output(1 To UBound(testItems, 1), 1 To 1)
'Populate the output array based on the presence of
'a matching security.
For i = 1 To UBound(testItems, 1)
If IsEmpty(testItems(i, 1)) Then
output(i, 1) = "No Security"
Else
exists = False: On Error Resume Next
exists = securities(CStr(testItems(i, 1))): On Error GoTo 0
output(i, 1) = IIf(exists, "US", "Not a US Security")
End If
Next
'Write the output array to your sheet.
testSheet.Cells(2, "P").Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function RangeTo2DArray(rng As Range) As Variant
'Helper function to read range values into an array.
Dim v As Variant
Dim arr(1 To 1, 1 To 1) As Variant
v = rng.Value2
If Not IsArray(v) Then
arr(1, 1) = v
RangeTo2DArray = arr
Else
RangeTo2DArray = v
End If
End Function
Private Sub PopulateColumnCollection(ws As Worksheet, columnIndex As String, col As Collection)
'Helper sub to read a column of values into a collection.
Dim rng As Range
Dim v As Variant
Dim i As Long
With ws
Set rng = .Range( _
.Cells(1, columnIndex), _
.Cells(.Rows.Count, columnIndex).End(xlUp))
End With
v = RangeTo2DArray(rng)
If col Is Nothing Then Set col = New Collection
On Error Resume Next 'this avoids duplicates.
For i = 1 To UBound(v, 1)
col.Add True, CStr(v(i, 1))
Next
End Sub
Can anyone explain me if I can recursively loop through a sorted list inside a For loop?
I am looping through a column, and once I found an exact match (lets say EALOLES string), then I want to keep on looping until there's no more matches.
Data example
For i = 2 to UsedRange.Rows.Count
If (Cells(i, 12).Value = "EALOLES") Then
' Start an inner loop until EALOLES ends, increment i++
' Perform actions appropriate to EALOLES case
Exit For
End If
next i
This is all fine with an inner loop, but I was just wondering if this could be achieved also with a recursive function and how that would look like? From the example I learned about recursion, I would imagine to loop from end of workbook to the beginning.
Note, I am not stating it would be a better solution, neither an inner loop, but I am just very curious.
Your question is basically is this a candidate for recursion, and the answer is no. Iteration with your inner loop is the better solution in this case.
Read the article: Recursion and Iteration to learn when to use each.
Assuming your data are sorted, you could take advantage of that
Dim nOccurrences As Long
Dim cell As Range
With Intersect(ActiveSheet.UsedRange, Columns(12))
nOccurrences = WorksheetFunction.CountIf(.Cells, "EALOLES")
If nOccurrences > 0 Then
For Each cell in .Resize(nOccurrences).Offset(.Find(What:= "EALOLES", LookIn:=xlValues, LookAt:=xlWhole, After:=.Cells(.Rows.Count)).Row-1)
‘Do your things
Next
End If
End With
This is not an efficient method of returning the start and stop positions of a string in a sorted list but as an intellectual excercise this should do.
dim i as long, j as long
For i = 2 to UsedRange.Rows.Count
If (Cells(i, 12).Value = "EALOLES") Then
for j=i to UsedRange.Rows.Count
If (Cells(j+1, 12).Value <> "EALOLES") Then
exit for
end if
next j
Exit For
End If
next i
debug.print "start: " & i
debug.print "end: " & j
I was musing with a slightly different take on the same theme
Define a range to loop over. See if the value exists in the range. If it does, start at the first match and keep looping the loop range until the cell value differs from the specified target string.
Option Explicit
Sub StopAtEnd()
Dim wb As Workbook
Dim ws As Worksheet
Dim endRow As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet5") 'change as needed
endRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
Dim loopRange As Range
Set loopRange = ws.Range("L1:L" & endRow) 'Change start row as required
Dim currentCell As Range
Dim targetString As String
Dim startRow As Long
targetString = "EALOLES"
On Error GoTo Errhand
startRow = Application.Match(targetString, loopRange, 0)
Do Until ws.Range("L" & startRow) <> targetString
Debug.Print ws.Range("L" & startRow).Address
startRow = startRow + 1
Loop
Exit Sub
Errhand:
MsgBox "Target string not found"
End Sub
Shout out to #DisplayName who pointed out this could be written instead as:
Option Explicit
Sub StopAtEnd()
Dim wb As Workbook
Dim ws As Worksheet
Dim endRow As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as needed
endRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
Dim loopRange As Range
Set loopRange = ws.Range("L1:L" & endRow) 'Change start row as required
Dim currentCell As Range
Dim targetString As String
Dim startRow As Variant
targetString = "EALOLES"
startRow = Application.Match(targetString, loopRange, 0)
If IsError(startRow) Then
MsgBox "Target string not found"
Else
Do Until ws.Range("L" & startRow) <> targetString
Debug.Print ws.Range("L" & startRow).Address
startRow = startRow + 1
Loop
End If
End Sub