Excel VBA: FindNext in nested loops - vba

I am trying to create a loop using the .Find function within another loop which is already using .Find. I want to search for strings that I have saved in an array.
For example, these are the string values saved in the array strItem in Sheet1.
"unit1", "unit2", "unit3"
I would like to search them one by one from Sheet2. Sheet2 looks like this:
unit1
unit2
unit3
unit1.pdf
text1
subject1
subject2
subject3
text2
=========
unit2.pdf
text1
subject1
subject2
subject3
text2
=========
unit3.pdf
text1
subject1
subject2
subject3
text2
=========
After searching for "unit1.pdf", I search all cells below it for "subject", and get cell values of subject1, 2, and 3. The search for "subject" cells should stop at the next cell which contains "====".
Next I search for "unit2", and if found search for "subject" cells under it as before. Again, stop at the cell containing "====". And so on.
In my code, what I am trying to do was
Search for the string "unit".
Use its .row as the range to start searching for "subject".
Return all subjects until the cell contains "====". This is a part of my code that I can't really make to work.
Code:
Wb2.Sheets("Sheet2").Activate
With Wb2.Sheets("Sheet2").Range("A1:A1048575")
For Each strItem In arrExcelValues
myStr = strItem & ".pdf"
Set p = .Find(What:=myStr, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not p Is Nothing Then
firstAddress = p.Address
Do
myStr2 = p.row
strStart = "A" & myStr2
strEnd = "A1048575"
With Wb2.Sheets("Sheet2").Range(strStart, strEnd)
Set p1 = .Find(What:="Subject", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not p1 Is Nothing Then
firstAddress = p1.Address
Do
myStr2 = myStr2 + 1
If p1.Offset(myStr2, 0).Value = "====" Then
Exit Do
Else
MsgBox p1.Value & strItem
End If
Set p1 = .FindNext(p1)
Loop While Not p1 Is Nothing And p1.Address <> firstAddress
Else
MsgBox "Not found"
End If
End With
Set p = .FindNext(p)
Loop While Not p Is Nothing And p.Address <> firstAddress
Else
MsgBox "Not found"
End If
Next
End With

You're not far off, but there are a couple of things to think about:
It seems you know the order of your data, you can use this to make life easier than using Find on the entire column.
You cannot use nested With statements unless you are going further into the child elements. It is good you are trying to fully qualify things, but be careful. For instance,
' This is okay
With ThisWorkbook.Sheets("Sheet2")
With .Range("A1")
MsbBox .Value
End With
With .Range("A2")
MsgBox .Value
End With
End With
' This is not okay, and present in your code
With ThisWorkbook.Sheets("Sheet2").Range("A1")
MsgBox .Value
With ThisWorkbook.Sheets("Sheet2").Range("A2")
Msgbox .Value
End With
End With
I have taken the ideas in your code, and re-written it to be a bit clearer, and hopefully achieve what you want. See the comments for details:
Dim Wb2 As Workbook
Dim lastRow As Long
Set Wb2 = ThisWorkbook
' Get last used row in sheet, so search isn't on entire column
lastRow = Wb2.Sheets("Sheet2").UsedRange.Rows.Count
' Set up array of "unit" values
Dim arrExcelValues() As String
arrExcelValues = Split("unit1,unit2,unit3", ",")
' Declare variables
Dim pdfCell As Range
Dim eqCell As Range
Dim eqRow As Long
eqRow = 1
Dim subjCell As Range
Dim strItem As Variant
' Loop over unit array
With Wb2.Sheets("Sheet2")
For Each strItem In arrExcelValues
' Find the next "unitX.pdf" cell after the last equals row (equals row starts at 1)
Set pdfCell = .Range("A" & eqRow, "A" & lastRow).Find(what:=strItem & ".pdf", lookat:=xlPart)
If Not pdfCell Is Nothing Then
' pdf row found, find next equals row, store row value or use last row
Set eqCell = .Range("A" & pdfCell.Row, "A" & lastRow).Find(what:="====", lookat:=xlPart)
If eqCell Is Nothing Then
eqRow = lastRow
Else
eqRow = eqCell.Row
End If
' Loop through cells between pdf row and equals row
For Each subjCell In .Range("A" & pdfCell.Row, "A" & eqRow)
' If cell contents contain the word "subject" then do something (display message)
If InStr(UCase(subjCell.Value), "SUBJECT") > 0 Then
MsgBox "Subject: " & subjCell.Value & ", Unit: " & strItem
End If
Next subjCell
Else
MsgBox "Item not found: " & strItem & ".pdf"
End If
Next strItem
End With

Related

Excel VBA Code to Combine (concat) cells with If Statement and/or ContainWord

I am attempting to add VBA code which will combine cells which would be more complete together. For example, each cell which contains the word "Class" is good on its own. However, if a cell contains "Classes", it should also contain "and". Some of the cells which contain "Classes" do not contain "and". That cell which contains the associated "and" is one or two lines down below, but it is the next cell.
Classes GE, GH, GK, GL, GN, GP,
GQ and IG
Class LD
Class LP
Classes H, HB, HC, HD, HE, HG,
HI, HJ, HK, HL, HN, HP and HQ
Classes E, EA, EB, EC, ED, EG and EI
The line with "Classes E, EA, EB, EC, ED, EG and EI" is good on its own as the "Classes" and "and" are in the same cell. The cell containing "Classes GE..." and the cell below it, "GQ and IG" need to now become one cell.
The code I have so far is:
Dim cell As Range
Dim ContainWord, ContainWord2, ContainWord3, ContainWord4 As String
Dim lngTotRows As Integer
lngTotRows = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1:BB" & lngTotRows)
ContainWord = "Class"
ContainWord2 = "Classes"
ContainWord3 = "and"
ContainWord4 = ","
'Delete all cells without the ContainWords
For Each cell In rng.Cells
If cell.Find(ContainWord) Is Nothing And cell.Find(ContainWord2) Is Nothing
And cell.Find(ContainWord3) Is Nothing And cell.Find(ContainWord4) Is
Nothing Then cell.Clear
Next cell
Range("A1").Select
'Combine cells which have "classes" but not "and" with the subsequent cells
which contain "and"
For Each cell In rng.Cells
If InStr(cell, ContainWord2) > 0 And InStr(cell, ContainWord3) = 0 Then
My first task of deleting everything which did not contain those contain words works great. It's the next part I am having difficulty with. I have looked over a bunch of other threads regarding ifs and containwords and combine and InStr, but haven't been able to figure out what to do after the "Then". Any help would be much appreciated.
I saw a different logic in your data and therefore took a different approach: If the word "class" isn't in a cell's content then it must be appended to the previous. I also don't recommend to delete data (they took so much time to accumulate, lol:). Instead, my code below writes a new list. I placed this list on the same sheet but you could create it anywhere.
Before you try the code please set a suitable TargetColumn at the top of the code. I also recommend that you replace With Activesheet with something like With Worksheets("My List of Classes") which would make the code less accident prone.
Private Sub MergeClassList()
' 08 Jan 2018
Const TargetColumn As Long = 10 ' column to write result to
Dim Itm As String, Out As String
Dim Sp() As String ' helper to insert "and"
Dim Rt As Long ' Target row
Dim Rl As Long ' last used row
Dim R As Long
Application.ScreenUpdating = False
With ActiveSheet
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Rt = 2 ' start output in row 2
For R = 2 To Rl ' first data row = 2
Itm = Trim(.Cells(R, "A").Value)
If InStr(1, Itm, "class", vbTextCompare) = 1 Then
If Len(Out) Then
.Cells(Rt, TargetColumn).Value = Out
Rt = Rt + 1
End If
Out = Itm
Else
If Len(Out) Then
If Right(Out, 1) <> "," Then Out = Out & ","
Out = Replace(Out, " and", ",") & " "
End If
Out = Out & Itm
If InStr(Out, ",") And (InStr(1, Out, "and", vbTextCompare) = 0) Then
Sp = Split(Out, ",")
Do
Out = Left(Out, Len(Out) - 1)
Loop Until Right(Out, 1) = ","
Out = Left(Out, Len(Out) - 1) & " and" & Sp(UBound(Sp))
End If
End If
Next R
If Len(Out) Then .Cells(Rt, TargetColumn).Value = Out
End With
Application.ScreenUpdating = True
End Sub
Concatenate in vba can be substituted with "&" and strings
dim string1,string2 as string
dim nextCell as range
For Each cell In rng.Cells
string1= cell.text
if instr(string1, containword2) >0 and not instr(string1, containword3) >0 then
set nextcell = activeworksheet.usedrange.find(what:=containword3, after:=cell.address, _
lookat:=xlpart, lookinxlformulas, _
search order:= xlbyrows, searchdirection:=xlnext, _
matchcase:=false)
string2= nextcell.text
cell.text= string1 & " " & string2
nextcell.clear
end if
Next cell
code is untested, the idea is find the next cell that contains the word "and" and concatenate it with current cell. However, there is a case where next cell could contain both "Classes" and "and", which the above code would not work on. Not sure if you have this case in your data. Let me know if you do.

VBA Testing two values, if one is different, copy

I am having a fair amount of trouble with the code below:
Sub TestEmail()
Dim i As Long
Dim LastRow As Long
Dim a As Worksheet
Dim b As Worksheet
Dim strText
Dim ObjData As New MSForms.DataObject
Set a = Workbooks("Book2").Worksheets(1)
Set b = Workbooks("Book1").Worksheets(1)
LastRow = a.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
If Not IsError(Application.Match(a.Cells(i, 7).Value, b.Columns(3), 0)) And IsError(Application.Match(a.Cells(i, 4).Value, b.Columns(11), 0)) Then
a.Range("D" & i).Copy
ObjData.GetFromClipboard
strText = Replace(ObjData.GetText(), Chr(10), "")
b.Range("K" & ).Value = b.Range("K" & ).Value & " / " & strText
End If
Next i
End Sub
I face two problems, one has me stumped and the other is due to lack of knowledge:
The line after IF is supposed to check if two values (numbers) in both workbooks match, and if two other values (text) don't match. If all true, then it must copy a value from Book2 and add it to a cell in book1.
The problems are:
-The macro doesn't seem to recognise when the values match or not.
-In the last line before "End If", I don't know how to tell excel to copy the text into the cell that didn't match in the second check.
I am sorry if I am not clear enough, this is hard to explain.
I'm hoping one of the experts knows how to make this work.
Thanks in advance
You are using If Not condition 1 And condition 2, so you are saying that if it doesn't match both conditions, Then you run the code. What you want to make are Nested If Statements However, one is If and the other If Not
To copy you are missing the i After "K"&: b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
The Address of the Cells are inside the Range Function, which in your case would be:
//It is the cell of the email from the first Workbook tou are copying, where you input the column D
a.Range("D" & i).Copy
//Add to Workbook b in column K the value from Cell K#/value copied
b.Range("K" & i) = b.Range("K" & i).Value & " / " & strText
You can also make it like this: b.Range("K" & i) = b.Range("K" & i).Value & " / " & a.Range("D" & i)
This way you are matching lines, so only if the IDs are on the same rows on both Workbooks it will work. If they aren't, you will have to use Nesting Loops or .Find Function
EDIT:
If I understood it, the code below might work if you make some changes for your application, because i didn't have the data to test and columns, etc. Try to implement it.
LastRowa = a.Cells(Rows.Count, "A").End(xlUp).Row
LastRowb = b.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRowa
'Address of String to look for
LookForString = a.Worksheets(1).Cells(i, 4) '4 is the COLUMN_INDEX
'Range to look on Workbook a
With a.Worksheets(1).Range("D1:D" & LastRowa) 'choose column to look
'Function .Find String on book a
Set mail_a = .Find(LookForString, LookIn:=xlValues)
If Not mail_a Is Nothing Then
FirstAddress = mail_a.Address
Do ' Actions here
'Range to look on Workbook b
With b.Worksheets(1).Range("K1:K" & LastRowb) 'choose column to look
'Function .Find on Workbook b
Set mail_b = .Find(LookForString, LookIn:=xlValues)
If Not mail_b Is Nothing Then
FirstAddress = mail_b.Address
Do 'Actions
'Verify if two other values (text) don't match
If Not WRITE_MATCH_CONDITION_HERE Then
'No need to verify of they are equal because the .Find function used the same reference
'I will use .Cells with .Row and .Column just to show another way to do it and make it dynamic
b.Cells(mail_b.Adress.Row, mail_b.Adress.Column) = b.Cells(mail_b.Adress.Row, mail_b.Adress.Column).Value & " / " & a.Cells(mail_a.Adress.Row, mail_a.Adress.Column) 'choose columns
End If
Set mail_b = .FindNext(mail_b)
Loop While Not mail_b Is Nothing And mail_b.Address <> FirstAddress
End If
End With
Set mail_a = .FindNext(mail_a)
Loop While Not mail_a Is Nothing And mail_a.Address <> FirstAddress
End If
End With
Next i
End Sub
p.s.: The <> is missing on mail_a.Address <> FirstAddress and mail_b.Address <> FirstAddress, when i posted with

Using .Find() to find specific text in column

I'm having trouble making sure that my code uses what the end user inputs to find a set of data pertaining to that value and continues with the code there. For example, if the user were to input "V-" as the prefix to the tag number, in theory cell A7 should be selected after the code is complete. However, the code proceeds to run line "MsgBox "No blank cell was found below a tag number with prefix " & str & ".", vbExclamation" and select cell A3 due to the fact that it contains "V-" in the cell. I tried changing the Matchcase to true but it did not help. I also do not want the entered value to be case sensitive.
Code being used:
Private Sub Worksheet_Activate()
Dim msg As String
Dim Cell As Range
Dim str As String, firstcell As String
msg = "Would you like to find the next available tag number?"
result = MsgBox(msg, vbYesNo)
If result = vbYes Then
str = Application.InputBox("Enter The Tag Number Prefix ", "Prefix To Tag Number")
If str = "" Then Exit Sub
If Right(str, 1) <> "-" Then str = str & "-"
With Range("A:A")
Set Cell = .Find(str, lookat:=xlPart, MatchCase:=False)
If Not Cell Is Nothing Then
firstcell = Cell.Address
Do
If Cell.Offset(1, 0) = "" Then
Cell.Offset(1, 0).Select
Exit Sub
ElseIf InStr(LCase(Cell.Offset(1, 0)), LCase(str)) = 0 Then
Cell.Select
MsgBox "No blank cell was found below a tag number with prefix " & str & ".", vbExclamation
Exit Sub
End If
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And firstcell <> Cell.Address
End If
End With
Else
Cancel = True
End If
End Sub
If you want to find cells whose content begins with (e.g.) "V-" then
Set Cell = .Find(str & "*", lookat:=xlWhole, MatchCase:=False)
For the data below:
Sub tester()
With ActiveSheet.Columns(1)
Debug.Print .Find("C-" & "*", lookat:=xlWhole, _
MatchCase:=False).Address() '>> $A$3
Debug.Print .Find("V-" & "*", lookat:=xlWhole, _
MatchCase:=False).Address() '>> $A$5
End With
End Sub

Appending to a cell value in VBA

I'm sure there's an obvious answer here, but I'm stuck. This part in particular is throwing 424: Object Required. The really odd part, to me, is that it does successfully append 0s to the column, but then halts, and doesn't continue.
If cellLen < 9 Then
Set C.Value = 0 & C.Value
End If
The rest of the code is below for clarity. In case it's not clear, this is the intended code flow:
Grabs named fields
Copies those columns to a new sheet
Renames them and deletes the original sheet
Creates some new sheets for use with a different script
Searches for missing leading 0s in a specific column
Adds them back in (this is the part the breaks)
Deletes rows where that specific column's cell value is 0
Pulls that cleaned-up column out to a new file and saves it
Sub Cleanup_Mapwise_Import()
Dim targetCols As Variant
Dim replColNames As Variant
Dim index As Integer
Dim found As Range
Dim counter As Integer
Dim headerIndex As Integer
Dim question As Integer
Dim rowCount As Variant
Dim colNum As Variant
Dim colLetter As Variant
Dim C As Range
Dim cellLen As Integer
' Add or remove fields to be copied here
targetCols = Array("gs_account_number", "gs_meter_number", "gs_amr_identification", _
"gs_amr_phase", "gs_city", "Name", "Phase", _
"gs_rate_schedule", "gs_service_address", _
"gs_service_map_location", "gs_service_number")
' Put the same fields from above in the desired order here, with the desired name
replColNames = Array("Acct #", "Meter #", "AMR ID", "AMR Phase", "City", _
"Name", "Phase", "Rate", "Address", "Srv Map Loc", "Srv Num")
counter = 1
ActiveSheet.Range("A1").Select
' This counts the number of columns in the source array and sets the index to that value
For index = LBound(targetCols) To UBound(targetCols)
Set found = Rows("1:1").Find(targetCols(index), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
' This is basically an insertion sort, and ends up with the columns in A:K
If Not found Is Nothing Then
If found.Column <> counter Then
found.EntireColumn.Cut
Columns(counter).Insert shift:=xlToRight
Application.CutCopyMode = False
End If
counter = counter + 1
End If
Next index
' There is a more dynamic way of doing this, using index
' As it is, replace A:K with the range of actual data
' PROTIP: targetCols is 1-indexed, and has 11 entries -->
' A:K encompasses that entire array -->
' Add/subtract 1 for each entry you add/remove
Range("A:K").Cut
Set TargetSheet = Sheets.Add(After:=Sheets(Sheets.Count))
TargetSheet.Name = "Contributors"
Range("A:K").Insert
question = MsgBox("Do you want to delete the original sheet?", vbYesNo + vbQuestion, "Delete Sheet")
If question = vbYes Then
Sheets(1).Activate
Sheets(1).Delete
Else
End If
Sheets.Add.Name = "Data"
Sheets("Contributors").Move After:=Sheets("Data")
Sheets.Add.Name = "Graph"
Sheets("Graph").Move After:=Sheets("Contributors")
Sheets("Data").Activate
Range("A1").Value = "Date/Time"
Range("B1").Value = "kW"
Range("C1").Value = "Amps"
' Yes, counter is 0-indexed here, and 1-indexed previously
' headerIndex does an absolute count of 0 To # targetCols, whereas index is relative
' If you change these, there is a non-zero chance that the For will throw an error
counter = 0
Sheets("Contributors").Activate
ActiveSheet.Range("A1").Select
For headerIndex = 0 To (UBound(targetCols) - LBound(targetCols))
ActiveCell.Value = replColNames(counter)
' If you don't use a Range, it fits columns based on headers, which isn't large enough
' A1:Z500 is a big enough sample to prevent that
ActiveCell.Range("A1:Z500").Columns.AutoFit
ActiveCell.Offset(0, 1).Select
counter = counter + 1
Next headerIndex
' Find column number with meters numbers, then assign its corresponding letter value
colNum = Application.WorksheetFunction.Match("Meter #", Range("A1:ZZ1"), 0)
colLetter = (Split(Cells(, colNum).Address, "$")(1))
rowCount = Range(colLetter & Rows.Count).End(xlUp).Row
'Range(colLetter & "2:" & colLetter & rowCount).Select
'Selection.SpecialCells(xlCellTypeBlanks).Select
'Selection.Delete Shift:=xlUp
' Meter numbers are 9 digits, so if one is shorter, assume a trimmed leading 0 and append it
For Each C In Range(colLetter & "2:" & colLetter & rowCount).Cells
' If cell type isn't set to text, the 0s will be non-visible, which while not an issue for the CSV, is confusing
' Note that this does not persist, as CSVs have no way of saving Excel's formatting
C.NumberFormat = "#"
cellLen = Len(C.Value)
If C.Value = "0" Or cellLen = 0 Then
C.Delete shift:=xlUp
End If
If cellLen < 9 Then
Set C.Value = 0 & C.Value
End If
Next C
question = MsgBox("Do you want to create a CSV file with meter numbers for use with MDMS?", vbYesNo + vbQuestion, "MDMS File")
If question = vbYes Then
' Call CopyMeters for use with MDMS
Sheets("Contributors").Activate
CopyMeters
Else
End If
End Sub
Sub CopyMeters()
Dim index As Integer
Dim fileSaveName As Variant
Dim rowCount As Variant
Dim colNum As Variant
Dim colLetter As Variant
Dim cellLen As Integer
colNum = Application.WorksheetFunction.Match("Meter #", Range("A1:ZZ1"), 0)
colLetter = (Split(Cells(, colNum).Address, "$")(1))
rowCount = Range(colLetter & Rows.Count).End(xlUp).Row
MsgBox ("Filename will automatically be appended with ""Meter List""")
fileSaveName = Split(ActiveWorkbook.Name, ".")
fileSaveName = fileSaveName(LBound(fileSaveName)) & " Meter List"
'For Each C In Range(colLetter & "2:" & colLetter & rowCount)
' C.NumberFormat = "#"
' cellLen = Len(C)
' If C.Value = "0" Or cellLen = 0 Then
' C.Delete shift:=xlUp
' End If
' If cellLen < 9 And cellLen <> 0 Then
' C.Value = "0" & C.Value
' End If
'Next C
Range(colLetter & "1:" & colLetter & rowCount).EntireColumn.Copy
Set newBook = Workbooks.Add
newBook.Worksheets("Sheet1").Range("A1").PasteSpecial (xlPasteAll)
Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Columns.AutoFit
newBook.SaveAs Filename:=fileSaveName, FileFormat:=xlCSV, CreateBackup:=False
End Sub
The error message is telling you that C is not an object. Therefore, you do not need the Set statement. Change your code to this:
If cellLen < 9 Then
C.Value = 0 & C.Value
End If
Why not just change the numberformat on the range? Or use a function for the value? A function would be something like
Public Function FormatValues(ByVal Input as String) as String
If Input <> vbNullString Then FormatValues = Format(Input, "000000000")
End Function
And it would be called like:
C.Value = FormatValues(C.Value)
But, if you're strictly interested in what the value looks like, and not as much as what the value is (since the leading zero will only be retained for strings) you could do something like this:
Public Sub FixFormats()
ThisWorkbook.Sheets("SomeSheet").Columns("A").NumberFormat = "000000000")
End Sub
This would format Column A of Worksheet "SomeSheet" to be of the format "0000000" which means numbers would look like "000000001", "000000002" so on so forth, regardless of whether something like "2" was actually entered.

Excel VBA macro for one column, if true, apply formula to another column

For context:
I would like for the program to look through column B, identify the first "< / >" (which is purely stylistic and can be changed if necessary - it's only used to break up the data) as the start of a week at cell B9 and the next "< / >" (end of the week) at B16. So the range I'm interested in is B10-B15. It would then sum those numbers from J10 to J15 (Earned column) and paste that sum in L16 (Week Total column). The same could then be done with 'Hours' and 'Week Hours'. For the following week (and thereafter) the 'end of the week' "< / >" becomes the start of the week, and the program continues until B200.
I don't have any experience with VBA and so made the following incomplete attempt (based on what I had found online) but felt too out of my depth not to ask for help.
Sub Work()
Dim rng As Range
Dim rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound Is "</>" Then
If Cell = "</>" Then
End If
End Sub
Thank you for any help and please let me know if I can be clearer or elaborate on something.
The following code will loop through 200 lines, looking for your symbol. When found, it will sum the numbers in column J for rows between the current row and the last symbol.
I've included two lines that will update the formula. To me, the 2nd one is easier to understand.
Sub Work()
Dim row As Integer
row = 4
Dim topRowToAdd As Integer 'Remember which row is the
'top of the next sum
topRowToAdd = 4
While row <= 200
If Cells(row, 2) = "</>" Then
'Cells(row, 10).FormulaR1C1 = "=SUM(R[" & -(row - topRowToAdd) & "]C[0]:R[" & -1 & "]C[0])"
Cells(row, 10).Value = "=SUM(J" & topRowToAdd & ":J" & row - 1 & ")"
topRowToAdd = row + 1
End If
row = row + 1
Wend
End Sub
Sub Work()
Dim rng As Range, rngFound As Range
Set rng = Range("B:B")
Set rngFound = rng.Find("</>")
If rngFound.Value2 = "</>" Then
'whatever you want to do
End If
End Sub
So at a second glance it looks like this. If you'd like to make it structured you'd need to use a countifs function first.
Sub Work()
Dim rng As Range, rngFound(1) As Range
Set rng = Range("B1:B200")
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
Set rngFound(1) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(0)) 'finds the first after the first (i.e. the second)
Set rngFound(0) = rngFound(0).Offset(1, 8) '8 is the difference between B and J, row shifts as per description, I advise you to make it a variable
Set rngFound(1) = rngFound(1).Offset(-1, 8)
If rngFound(1).Row > rngFound(0).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(1).Offset(1, 2).Formula = "=SUM(" & Range(rngFound(0), rngFound(1)).Address & ")" 'L column will have the sum as a formula
Else
MsgBox "There is a single match in " & rng.Address(False, False)
End If
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub
Now for the grand finale:
Sub Work()
Dim rng As Range, rngFound() As Range, rngdiff(1) As Long, rngcount As Long
Set rng = Range("B1:B200")
rngcount = rng.Cells.Count
ReDim rngFound(rngcount)
rngdiff(0) = Range("J1").Column - rng.Column ' the range that needs to be summed is in column J
rngdiff(1) = Range("L1").Column - rng.Column ' the range containing the formula is in column L
On Error GoTo Err 'it is quite possible it will run into an error if there are no matches and I'm too lazy for structured solution
Set rngFound(0) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext) 'finds the first
'loop starts
For i = 1 To rngcount
Set rngFound(i) = rng.Find(What:="</>", LookAt:=xlWhole, SearchDirection:=xlNext, After:=rngFound(i - 1)) 'finds the next
If rngFound(i).Row > rngFound(i - 1).Row Then 'if it's not higher, then it recurred and found the first range again
rngFound(i).Offset(0, rngdiff(1)).Formula = "=SUM(" & Range(rngFound(i - 1).Offset(1, rngdiff(0)), rngFound(i).Offset(-1, rngdiff(0))).Address & ")" 'L column will have the sum as a formula
Else
Exit Sub 'if it recurred the deed is done
End If
Next i
If False Then
Err:
MsgBox "There are no matches in " & rng.Address(False, False)
End If
End Sub