I'm struggling to get this exercise done therefore I'm asking for your help.
I have a table with data as following:
picture with data
I need 2 loops:
1, one looping Column "BX" from last row to 2 and searching for 2 values (first day of a week
and last day of a week) in Column BV. Then subtracting corresponding values from Column "BW".
Example: Number 37 is last row value ("BX") which should be looked up in Column "BV" (twice),
get corresponding values: 15,5 and 14,25. Subtract them and get result.
2, second one would be going into any free column (i.e. "BZ") and inserting results of previous
subtractions one by one.
First part is done with a following code:
lastc = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
lastr = ws.Cells(ws.Rows.count, lastc).End(xlUp).Row
lastr2 = ws.Cells(ws.Rows.count, lastc - 2).End(xlUp).Row
For R = lastr To 2 Step -1
lastr = R
Set FindRow = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc))
FindRowNumber = FindRow.Row
Set CellPosition = Cells(FindRowNumber, lastc - 1)
Set FindRow2 = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
Find RowNumber2 = FindRow2.Row
Set CellPosition2 = Cells(FindRowNumber2, lastc - 1)
Next R
But I struggle to incorporate second loop and move results where I want them to.
Thank you for your tips.
I added operations to your code to accumulate and output results:
Sub test1()
Set ws = ActiveSheet
ws.Columns("BZ").ClearContents ' clear output column
lastc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lastr = ws.Cells(ws.Rows.Count, lastc).End(xlUp).Row
lastr2 = ws.Cells(ws.Rows.Count, lastc - 2).End(xlUp).Row
Dim col As New Collection 'declare and create collection for results accumulation
For R = lastr To 2 Step -1
lastr = R
Set FindRow = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc))
FindRowNumber = FindRow.Row
Set CellPosition = ws.Cells(FindRowNumber, lastc - 1)
Set FindRow2 = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
FindRowNumber2 = FindRow2.Row
Set CellPosition2 = ws.Cells(FindRowNumber2, lastc - 1)
col.Add CellPosition2 - CellPosition ' accumulate results in the collection
Next R
' output previously accumulated results one-by-one
cnt = 2 'skip header row
For Each col_element In col
ws.Cells(cnt, "BZ") = col_element
cnt = cnt + 1
Next
End Sub
In my opinion, an additional output loop is unnecessary, it would be
more correct to output the results in the same line as the processed
value in the "BX" column for a visual comparison of the processed
value and the result
Option 2
Sub test2()
Set ws = ActiveSheet
ws.Columns("BZ").ClearContents ' clear output column
lastc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lastr = ws.Cells(ws.Rows.Count, lastc).End(xlUp).Row
lastr2 = ws.Cells(ws.Rows.Count, lastc - 2).End(xlUp).Row
For R = lastr To 2 Step -1
lastr = R
Set FindRow = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc))
FindRowNumber = FindRow.Row
Set CellPosition = ws.Cells(FindRowNumber, lastc - 1)
Set FindRow2 = ws.Range(ws.Cells(1, lastc - 2), ws.Cells(lastr2, lastc - 2)).Find(What:=ws.Cells(R, lastc), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
FindRowNumber2 = FindRow2.Row
Set CellPosition2 = ws.Cells(FindRowNumber2, lastc - 1)
ws.Cells(R, "BZ") = CellPosition2 - CellPosition ' output results
Next R
End Sub
Related
I want to find a range of same values in column A , and then calculate it average , can anyone help me ? below the code :
https://i.stack.imgur.com/bU1hW.png
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
Columns("A:A").Select
Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
'do it another thing
End If
End Sub
Thanks !
Solution 1
Try this
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
See image for reference.
Solution 2
Another easier approach will be to use formula. Enter the following formula in Cell E2
=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)
Drag/Copy down as required. Change range as per your data.
For details on AVERAGEIF see this.
EDIT : 1
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Dim dict As Object, c As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
c = aRng
For i = 1 To UBound(c, 1)
dict(c(i, 1)) = 1
Next i
.Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys) 'display uniques from column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
EDIT : 2 To get Min, instead of
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
use
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value
Use WorksheetFunction.AverageIf function, see code below :
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:A" & LastRow)
' average of values in column B of all cells in column A = 1
Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))
' average of values in column B of all cells in column A = 2
Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With
End Sub
This is using a variant array method. Try this.
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim vDB, vR(), rngDB, vResult()
Dim r As Integer, n As Long, j As Long, i As Integer
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
rngDB = .Range("a1", "b" & LastRow)
vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vResult(1 To r)
For i = 1 To r
n = 0
For j = 1 To LastRow
If vDB(i, 1) = rngDB(j, 1) Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = rngDB(j, 2)
End If
Next j
vResult(i) = WorksheetFunction.Average(vR)
Next i
.Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
End With
End Sub
To use the .Find Function
Find the values in column A excluding duplicates
Use the unique values on the Find Function
When the value is found, sum the value in column B and on a counter
Divide the sum value by the counter to obtain the average value
Dim ws As Worksheet
Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
Set ws = ThisWorkbook.Sheets(1)
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
For i = 2 To lastrow
Set c = ws.Cells(i, 1)
Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
x = Application.WorksheetFunction.CountIf(rngloop, c)
If x = 1 Then
'Debug.Print c 'Values in column A without duplicates
'Work with the values found
With rng
Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
If Not cellFound Is Nothing Then
FirstAddress = cellFound.Address
Do
SumValues = ws.Cells(cellFound.Row, 2) + SumValues
k = k + 1
Set cellFound = .FindNext(cellFound)
Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
AverageValues = SumValues / k
Debug.Print "Value: " & c & " Average: " & AverageValues
End If
End With
End If
k = 0
SumValues = 0
Next i
Note that the use of .Find is slower than CreateObject("Scripting.Dictionary"), so for large Spreadsheets the code of #Mrig is optimized
Please try this code:
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
'if found more than one value
'do it another thing
sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
Else
'do it another thing
End If
Next i
End Sub
Hope this help.
I have several columns and I am trying to copy the very last cell of each column into one column (in another worksheet).
This is my code that didn't work (I am looping through rows and columns):
Sub lastcell()
Dim lRow As Long
Dim lCol As Long
Dim i As Long
Worksheets("input").Select
With Worksheets("input")
Worksheets("output").Cells.ClearContents
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set ColRange = .Range(.Cells(1, 1), .Cells(5, lCol))
For Each ccol In ColRange
lRow = .Cells(.Rows.Count, ccol).End(xlUp).Rows.Count
For i = 2 To 6
Worksheets("output").Cells(i, 1) = .Cells(lRow, ccol)
Next i
Next ccol
End With
End Sub
You have one too many loops.
The lRow = .Cells(.Rows.Count, ccol).End(xlUp).Rows.Count should end with Row not .Rows.Count
Also with Set ColRange = .Range(.Cells(1, 1), .Cells(5, lCol)) you are going to loop through each column 5 times. The 5 should be a 1
There is no need to acivate or select the input sheet at the beginning of the code.
ccol should be declared
Sub lastcell()
Dim lRow As Long
Dim lCol As Long
Dim ccol as Range
Dim i As Long
With Worksheets("input")
Worksheets("output").Cells.ClearContents
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set colrange = .Range(.Cells(1, 1), .Cells(1, lCol))
i = 1
For Each ccol In colrange
lRow = .Cells(.Rows.Count, ccol.Column).End(xlUp).Row
Worksheets("output").Cells(i, 1).Value = .Cells(lRow, ccol.Column).Value
i = i + 1
Next ccol
End With
End Sub
We can simplify it even further with a simple for loop:
Sub lastcell()
Dim lRow As Long
Dim lCol As Long
Dim i As Long
With Worksheets("input")
Worksheets("output").Cells.ClearContents
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To lCol
lRow = .Cells(.Rows.Count, i).End(xlUp).Row
Worksheets("output").Cells(i, 1).Value = .Cells(lRow, i).Value
Next i
End With
Just for an FYI, this can also be done with a formula.
In your first cell on the output sheet put this formula:
=INDEX(input!A:Z,MAX(IFERROR(MATCH("ZZZ",INDEX(input!A:Z,0,ROW(1:1))),0),IFERROR(MATCH(1E+99,INDEX(input!A:Z,0,ROW(1:1))),0)),ROW(1:1))
And then copy/drag the formula down till you get 0s
My data is spreaded in many columns. In that, Column A and Column B has identical name (duplicates), while Column C to Q are values related to column B. I want to align column B to Column A while preserving subsequent values as it is.
NOTE: My question is very much similar to this one "Align identical data in two columns while preserving values in the 3rd in excel"
But in my case I want to preserve more subsequent columns (from C to Q). I played with code given as a solution by #Jeeped in that post but failed.
Can I get any help in this regards,
I have tried following code:
Sub aaMacro1()
Dim i As Long, j As Long, lr As Long, vVALs As Variant
With ActiveSheet
lr = .Cells(Rows.Count, 1).End(xlUp).Row
vVALs = Range("B1:C" & lr)
Range("B1:C" & lr).ClearContents
For i = 1 To lr
For j = 1 To UBound(vVALs, 1)
If vVALs(j, 1) = .Cells(i, 1).Value Then
.Cells(i, 2).Resize(1, 2) = Application.Index(vVALs, j)
Exit For
End If
Next j
Next i
End With
End Sub
I have made an attempt to change range("B1:C" & lr) to range ("B1:Q" & lr), but it didnt work.
After that I have changed .Resize (1,2) to .Resize (1,3), and it copied two subsequent rows but when i inset a code with .Resize (1,4), didn't work.
Hope this edited post helps to answer my question.
With best
Based on the code in the original link, should work with any number of columns ...
Option Explicit
Option Base 1
Sub aaMacro1()
Dim i As Long, j As Long, k As Long
Dim nRows As Long, nCols As Long
Dim myRng As Range
Dim vVALs() As Variant
With ActiveSheet
nRows = .Cells(Rows.Count, 1).End(xlUp).Row
nCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Set myRng = .Range(.Cells(2, 2), .Cells(nRows, nCols))
End With
nRows = nRows - 1
nCols = nCols - 1
vVALs = myRng.Value
myRng.ClearContents
For i = 1 To nRows
For j = 1 To nRows
If vVALs(j, 1) = ActiveSheet.Cells(i + 1, 1).Value Then
For k = 1 To nCols
myRng.Cells(i, k).Value = vVALs(j, k)
Next k
Exit For
End If
Next j
Next i
End Sub
Test input ...
Provides this output ...
you can try this
Option Explicit
Sub AlignDupes()
Dim lRow As Long, iRow As Long
Dim mainRng As Range, sortRange As Range
With ActiveSheet
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set mainRng = .Range("A1:A" & lRow)
Set sortRange = .Range("B1:Q1").Resize(mainRng.Rows.Count)
.Sort.SortFields.Clear
End With
Application.AddCustomList ListArray:=mainRng
With sortRange
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
iRow = 1
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Do While iRow <= lRow
Do While .Cells(iRow, 1) <> .Cells(iRow, 1).Offset(, -1)
.Rows(iRow).Insert
iRow = iRow + 1
lRow = lRow + 1
Loop
iRow = iRow + 1
Loop
End With
Application.DeleteCustomList Application.CustomListCount
End Sub
I have a small sample example sheet of data, which will be filled with much more data if I can get this process to work.
What I am trying to do is, based upon the number of cells that are filled in each row, insert the same number of blank lines under that same row and copy everything down all columns that are blank. I have attached two screenshots - a before and after of what the start and end look like, as well as the code used for implementing the blank row insert. So far, all it does is add 8 rows consistently, and is using an older version of Excel. I'm trying to translate it into the new VBA format, but I can't seem to get it to work.
Start:
The result I'm trying to achieve:
Code:
Sub IfYes()
Dim Col As Variant
Dim Y As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim C As Long
Dim StartRow As Long
Col = "AS"
Y = "Y"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Yes" Then
.Cells(R, Col).Offset(1, 0).Resize(8, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(8, 1).Value = .Cells(R, 1).Value
For C = 1 To 8 Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
I also have another bit of code that I've been trying to use to get this to function properly.
Dim wb1 As Workbook, ws1 As Worksheet
Dim lRow As Long
Dim LastRow As Range
Dim StartRow As Range
Dim i As Long
Set wb1 = Application.Workbooks.Open("Z:\Employee Folders\Jason\crystal spreadsheet - start.xls")
Set ws1 = wb1.Worksheets("AMZStart")
With ws1
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Cells(lRow, "B") = "AMZ" Then Rows(lRow).Offset(1, 0).EntireRow.Insert
Next lRow
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 1
StartRow = 1
For i = StartRow To LastRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")"
StartRow = i + 1
End If
Next
End With
End Sub
I find that storing the values in variant arrays can help.
Sub expand_Entries()
Dim v As Long, vAMZs As Variant, vVALs As Variant
Dim rw As Long, c1 As Long, c2 As Long, c As Long, cs As Long
With Worksheets("Sheet2")
c1 = Application.Match("status", .Rows(1), 0)
c2 = .Cells(1, Columns.Count).End(xlToLeft).Column
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
cs = Application.CountA(.Cells(rw, c1 + 1).Resize(1, c2 - c1))
If CBool(cs) Then
vVALs = .Cells(rw, 1).Resize(1, c1 - 1).Value2
With .Cells(rw, c1).Resize(1, cs + 1)
vAMZs = .Cells.Value2
.Offset(0, 1).ClearContents
End With
For c = UBound(vAMZs, 2) To LBound(vAMZs, 2) + 1 Step -1
.Cells(rw + 1, 1).Resize(1, c1 - 1).EntireRow.Insert
.Cells(rw + 1, 1).Resize(1, c1 - 1) = vVALs
.Cells(rw + 1, 8) = vAMZs(1, c)
Next c
End If
Next rw
End With
End Sub
You can use a the CountA Worksheet Function inside your IF block to determine the count of filled cells. Then just replace the 8's with the count of each row.
See code:
If .Cells(R, Col) = "Yes" Then
'get count
Dim iCells As Integer
iCells = WorksheetFunction.CountA(.Range("A" & R & ":R" & R))
.Cells(R, Col).Offset(1, 0).Resize(iCells, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(iCells, 1).Value = .Cells(R, 1).Value
For C = 1 To iCells Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
I'm trying to look for "nFormat" but just in the begin (just in the first 7 characters). If I found it, I need to look at the last character from the line above, if it is not # I need to write it and put both line together
My program is:
Sub Line_Config()
Dim Lrow As Long
Dim Lastrow As Long
Dim Prow As Long
Dim atual As String
Dim nextRow As String
Dim fGet As Range
Dim fnFormat As Range
Dim fa As Range
With Sheets("Get_Command")
.Select
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
' Start the loop
For Lrow = Lastrow To 2 Step -1
Prow = Lrow - 1
Set fGet = Cells(Lrow, 1).Find("Get:", LookIn:=xlValues)
If fGet Is Nothing Then 'If Get: is not found
Set fnFormat = Cells(Lrow, 1).Find("nFormat", LookIn:=Left(Cells(Lrwo, 1), 7))
If Not fnFormat Is Nothing Then 'If nFormat is found
Set fa = Cells(Prow, 1).Find("#", LookIn:=Right(Cells(Prow, 1), 1))
If fa Is Nothing Then
atual = Cells(Lrow, 1).Value
nextRow = Cells(Prow, 1).Value + "#" + atual
Cells(Prow, 1).FormulaR1C1 = nextRow
Cells(Lrow, 1).EntireRow.Delete
End If
Else
atual = Cells(Lrow, 1).Value
nextRow = Cells(Prow, 1).Value + atual
Cells(Prow, 1).FormulaR1C1 = nextRow
Cells(Lrow, 1).EntireRow.Delete
End If
End If
Next Lrow
.Columns("A").Replace _
What:="#", Replacement:=" ", _
LookAt:=xlPart, SearchOrder:=xlByColumns
End With
End Sub
Excel told me the error is in:
Set fnFormat = Cells(Lrow, 1).Find("nFormat", LookIn:=Left(Cells(Lrwo, 1), 7))
How can I change this?
Thanks
You get an error for this call
Set fnFormat = Cells(Lrow, 1).Find("nFormat", LookIn:=Left(Cells(Lrwo, 1), 7))
Because the parameter LookIn is not used to define a range to use the Find command on, but it is used to define whether to look in values or formulas in that range.
LookIn can assume the values of the enumeration XlFindLookIn : xlComments, xlFormulas and xlValues.
You should use the InStr(Start, String1, String2, Compare) function:
Dim tString as String
tString = Left(Cells(Lrow, 1).Value, 7)
If InStr(1, "nFormat", tString, Compare:=vbTextCompare) > 0) then
'nFormat was found, do stuff
End If