Public Sub caInvCompressRows(p_strInv As String)
Dim intRow As Integer
Dim intRowMch As Integer
Dim intCol As Integer
Dim bUsed As Boolean
Dim strTemp As String
Dim strSheet As String
Dim intSaveRow As Integer
strSheet = "cordINV-" & p_strInv
Call utlUnProtectSheet(strSheet, "alcatraz")
Sheets(strSheet).Select
Cells.Select
Rows.EntireRow.Hidden = False
Range("A1").Select
intRowMch = caINV_ROW_FIRST
While Cells(intRowMch, 1).Value <> "" Or Cells(intRowMch, 11).Value <> ""
For intRow = intRowMch + 1 To intRowMch + 6
If Cells(intRow, 1).Value = "" Then
If Cells(intRow, 11).Value = "" Then
Rows(intRow).EntireRow.Hidden = True
End If
End If
Next intRow
intRowMch = intRowMch + 9
Wend
End Sub
I want to hide rows that don't have data in them with the use of a button. each row contains three different groups of data that change which rows would need to be hidden. all data is pulled into columns C, O and AC and the rest is populated from that.
This formula checks if there is anything in row 2, simply by concatenating the whole row, trimming the result, and check if it is nothing but an empty string:
=TRIM(TEXTJOIN("";FALSE;2:2))=""
Sub HideRows()
If Range("d2").Value = "" Then
If Range("r2").Value = "" Then
If Range("af2").Value = "" Then
Rows("2:2").EntireRow.Hidden = True
End If
End If
End If
End Sub
Related
Excel spreadsheet
I have a set of over 10,000 lines of text strings in column A (Input), and I need to get the number (in case there is only one) or a sum of both (in case there are two).
Code
Here is the VBA code I have:
Sub ExtractNumericStrings()
Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long
With ActiveSheet
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
strTemp = rngTemp.Value2 ' Get string value of each cell
lngTemp = Len(strTemp) 'Get length of string
currNumber1 = 0 ' Reset value
currNumber2 = 0 ' Reset value
' Get first number
currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
' Get second number if exists
' First strip out first number
strTemp = Replace(strTemp, currNumber1, "")
If Len(strTemp) <> 0 Then
currNumber2 = fncGetNumericValue(strTemp, 1)
End If
' now paste to sheet
If currNumber1 <> 0 And currNumber2 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
rngTemp.Offset(0, 2).Value = "sum of the numbers"
ElseIf currNumber1 <> 0 Then
rngTemp.Offset(0, 1).Value = currNumber1
End If
Next rngTemp
End With
Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")
End Sub
Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency
Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long
' Reset
lngCount = 1
lngTemp = 1
varTemp = ""
On Error Resume Next
If IsNumeric(Left(strTemp, lngCount)) Then
Do While IsNumeric(Left(strTemp, lngCount)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
Else
' First clear non-numerics from string
lngTemp = 1
Do While IsNumeric(Left(strTemp, 1)) = False
lngTemp = lngTemp + 1
strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
If lngTemp > Len(strTemp) Then
Exit Do
End If
Loop
' Then extract second number if exists
If strTemp <> "" Then
Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
varTemp = Left(strTemp, lngCount)
lngCount = lngCount + 1
If lngCount > Len(strTemp) Then
Exit Do
End If
Loop
End If
End If
' Retrun Value
If IsNumeric(varTemp) Then
fncGetNumericValue = CCur(varTemp)
Else
fncGetNumericValue = 0
End If
End Function
Here is what I'm trying to do:
https://www.youtube.com/watch?v=EjHnJVxuWJA
I have very limited knowledge of VBA, so please excuse me if I ask any stupid question. Running this thing successfully will save me hips of time. thanks!
Something like this:
Private Sub extract_num()
Dim cell as Range
Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Dim values() As String
Dim i as Byte
Dim temp as Double
For Each cell in ws.Range("A2:A" & lr)
If Not isEmpty(cell) Then
values = Split(cell, " ")
For i = LBound(values) to UBound(values)
values(i) = Replace(values(i), ",", ".")
If isNumeric(values(i)) Then
temp = temp + values(i)
End If
Next i
cell.Offset(0, 2) = temp
temp = 0
End If
Next cell
End Function
This is presuming:
a) Individual words and numbers are always separated by space "123 abc 321"
b) Commas "," are used as an arithmetic floatpoint separator ##,##
Slightly different approach from Rawrplus
Option Explicit
Sub UpdateTotals()
Dim aRawValues As Variant
Dim iLRow&, iRow&, iArr&
Dim dTotal#
With ThisWorkbook.Worksheets("Sheet1") '<-- Change the sheet name to your sheet
iLRow = .Cells(Rows.Count, 1).End(xlUp).Row ' Get row count
For iRow = 1 To iLRow ' Loop through all rows in the sheet
aRawValues = Split(.Range("A" & iRow).Value, " ") ' Create and array of current cell value
For iArr = LBound(aRawValues) To UBound(aRawValues) ' Loop through all values in the array
dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", ".")) ' Add the returned double to total
Next
.Range("B" & iRow).Value = dTotal ' Set value in column B
dTotal = 0# ' Reset total
Next
End With
End Sub
Function ReturnDouble(ByVal sTextToConvert As String) As Double
Dim iCount%
Dim sNumbers$, sCurrChr$
sNumbers = ""
For iCount = 1 To Len(sTextToConvert)
sCurrChr = Mid(sTextToConvert, iCount, 1)
If IsNumeric(sCurrChr) Or sCurrChr = "." Then
sNumbers = sNumbers & sCurrChr
End If
Next
If Len(sNumbers) > 0 Then
ReturnDouble = CDbl(sNumbers)
Else
ReturnDouble = 0#
End If
End Function
I have the following issue: In one workbook I have multiple sheets.
On Sheet 2 in column "D" starting on row 2, Is a list of 300+ prefixes of 4 digits long e.g. XFTZ, GHTU, ZAQS etc.
On Sheet 1 in column "R" starting on row 3, Is a list of 1000+ values that can have the following values e.g.: AAAA1234556 and ZAQS12565865.
The first value AAAA...... is allowed, where the second value ZAQS..... Should throw an error message when running the VBA code.
The list of values in both sheets can grow over time, so I would like to avoid hard coding of records. I would expect best solution here is to use something like this:
LastRowNr = Cells(Rows.Count, 1).End(xlUp).Row
Try something like the following, replacing Sheet1 with the name in which the actual data is located
Option Explicit
Private Sub searchPrefix()
Dim RangeInArray() As Variant
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim tmpSrch As String
Dim i As Long
LastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 18).End(xlUp).Row
LastRow2 = Worksheets("PREFIXES").Cells(Rows.Count, 4).End(xlUp).Row
RangeInArray = Application.Transpose(Worksheets("PREFIXES").Range("D1:D" & LastRow2).Value)
For i = 3 To LastRow1
If Len(Worksheets("Sheet1").Cells(i, 18).Value) >= 3 Then
tmpSrch = Left(Worksheets("Sheet1").Cells(i, 18).Value, 4) '18: column R
If IsInArray(tmpSrch, RangeInArray) Then
Worksheets("Sheet1").Cells(i, 18).Interior.ColorIndex = xlNone
Worksheets("Sheet1").Cells(i, 18).Font.ColorIndex = 0
Worksheets("Sheet1").Cells(i, 18).Font.Bold = False
Else
Worksheets("Sheet1").Cells(i, 18).Interior.Color = RGB(252, 134, 75)
Worksheets("Sheet1").Cells(i, 18).Font.Color = RGB(181, 24, 7)
Worksheets("Sheet1").Cells(i, 18).Font.Bold = True
End If
End If
Next
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Option Explicit
Sub searchPrefix()
Sheets("PREFIXES").Select
Dim CellCntnt As String
Dim tmpSrch As String
Dim isFound As Boolean
isFound = False
Dim QtySrchChar As Integer
QtySrchChar = 4
Dim Cnt As Integer
Cnt = 0
Dim Tag As Integer
Cells.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Cnt = Cnt + 1
ActiveCell.Offset(1, 0).Select
Loop
For Tag = 1 To Cnt - 1
CellCntnt = Cells(1 + i, 1).Value
tmpSrch = Left(CellCntnt, QtySrchChar)
Cells.Range("G1").Select
Do Until IsEmpty(ActiveCell)
If Left(ActiveCell.Value, QtySrchChar) = tmpSrch Then
QtySrchChar = QtySrchChar + 1
tmpSrch = Left(CellCntnt, QtySrchChar)
isFound = True
MsgBox ("True Tags introduced with Std.Prefix " & tmpSrch)
End If
If isFound Then
isFound = False
MsgBox ("False Tags introduced with Std.Prefix " & tmpSrch)
Cells.Range("G1").Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
Next Tag
End Sub
I am trying to build a collection and take the Count of Unique Values from that Collection but am getting an error in building a Collection itself. Can anyone suggest me where I am going wrong. Kindly Share your thoughts. Please let me know how to find out the COUNT of UNIQUE VALUES as well.
Sub trial()
Dim sampleVisualBasicColl As Collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
sampleVisualBasicColl.Add Rng
Else
End If
Next
Debug.Print (sampleVisualBasicCol1)
End Sub
Using a collection you can just add Joh to the collection and then count the items:
'Using a collection
Sub Col_test()
Dim cCol As Collection
Dim i As Long
Set cCol = New Collection
On Error GoTo Err_Handler
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Left(.Cells(i, 13), 3) = "Joh" Then
cCol.Add .Cells(i, 13).Value, .Cells(i, 13).Value
End If
Next i
End With
Debug.Print cCol.Count
On Error GoTo 0
Exit Sub
Err_Handler:
Select Case Err.Number
Case 457 'This key is already associated with an element of this collection
Err.Clear
Resume Next
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure Col_test."
Err.Clear
End Select
End Sub
If you want the count of each item (Joh, Ben... whatever else you have) then use a dictionary:
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = Left(.Cells(i, 13), 3)
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
For Each key In dict.keys
Debug.Print key & " = " & dict(key)
Next key
End Sub
Note: I'm using Cells within the code rather than Range. Cells(2,13) is M2 (13th column, 2nd row).
I find this link very helpful with dictionaries: https://excelmacromastery.com/vba-dictionary/
As a further update (after answer accepted) and using the lists you gave in your question here: Excel VBA - Formula Counting Unique Value error this code with dictionaries will return Joh = 4, Ian = 3
'Using a dictionary.
Sub Dic_Test()
Dim dict As Object
Dim dictFinal As Object
Dim i As Long
Dim sValue As String
Dim key As Variant
Dim keyFinal As String
Set dict = CreateObject("Scripting.Dictionary")
Set dictFinal = CreateObject("Scripting.Dictionary")
'Get the unique values from the worksheet.
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To 20
If Len(.Cells(i, 13)) >= 3 Then
sValue = .Cells(i, 13).Value
If dict.exists(sValue) Then
dict(sValue) = dict(sValue) + 1
Else
dict(sValue) = 1
End If
End If
Next i
End With
'Count the unique values in dict.
For Each key In dict.keys
keyFinal = Left(key, 3)
If dictFinal.exists(keyFinal) Then
dictFinal(keyFinal) = dictFinal(keyFinal) + 1
Else
dictFinal(keyFinal) = 1
End If
Next key
For Each key In dictFinal.keys
Debug.Print key & " = " & dictFinal(key)
Next key
End Sub
You need to create the collection as well as declaring it.
Sub trial()
Dim myCol As Collection
Set myCol= New Collection ' creates the collection
For i = 2 To 10
Rng = Range("M" & i).value
StartsWith = Left(Rng, 3)
If StartsWith = "Joh" Then
myCol.Add Rng
Else
End If
Next
For each x in myCol
Debug.Print x
Next x
End Sub
Hey this code will help u since it's collecting Unique values in Listbox,,
Private Sub UserForm_Initialize()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").Value ="John". End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Me.ListBox1.AddItem vNum
Next vNum
End Sub
You have not declared Variable Rng & i these are the most important thing to do. Meanwhile I would like to suggest this Formula,,
=Sum(if(Frequency (if(Len(B2 :B20) >0,Match(B2 :B20, B2 :B20, 0),""),if(Len(B2 :B20) >Match(B2 :B20, B2 :B20, 0),"",))>0,1))
Its Array formula so finish with Ctrl +shift +enter.
You can use this one also,
Sub CountUnique()Dim i, count, j As Integer count = 1 For i = 1 To 470 flag = False If count
1 Then For j = 1 To count If Sheet1.Cells(i,
3).Value = Sheet1.Cells(j, 11).Value Then flag
= True End If Next j Else flag = False End If If flag = False Then Sheet1.Cells(count,
11 ).Value = Sheet1.Cells(i, 3).Value count = count + 1 End IfNext i Sheet1.Cells( 1 ,
15 ).Value = count End Sub
I have code that open's up an excel file used for mapping data. Then opens up a transaction file and appends columns to the file based on the mapping data. It works however I am having speed issues, it runs slow. If I click and hold the scroll bar in Excel it speeds up but when I let up the mouse button it slows back down, thoughts?
Dim MapLocation As String
Dim MapHeader As Integer
Dim MapColumnLegacy As Integer
Dim MapColumnFE As Integer
Dim MapColumnClass As Integer
Dim MapColumnProject As Integer
Dim MapColumnTcode1 As Integer
Dim MapColumnTcode2 As Integer
Dim MapColumnTcode3 As Integer
Dim MapColumnTcode4 As Integer
Dim MapColumnTcode5 As Integer
'Dim MapLines As Integer
Dim TransLocation As String
Dim TransHeader As Integer
Dim TransLines As Integer
Dim TransColumnLegacy As Integer
Dim ConvertSheet As Integer
Dim Xl As New Excel.Application
Dim Xlsheet As Excel.Worksheet
Dim Xlwbook As Excel.Workbook
Dim OldAcctID() As String
Dim NewAcctID() As String
Dim NewProjID() As String
Dim NewClassID() As String
Dim NewTcode1ID() As String
Dim NewTcode2ID() As String
Dim NewTcode3ID() As String
Dim NewTcode4ID() As String
Dim NewTcode5ID() As String
Dim I As Integer
Dim J As Integer
Dim Sheet As Object
Sub AcctConv_Main()
Call Cleanup
Call File_Access
Call OpenExcelfile
End Sub
Sub Cleanup()
ReDim OldAcctID(TransLines) As String
ReDim NewAcctID(TransLines) As String
ReDim NewProjID(TransLines) As String
ReDim NewClassID(TransLines) As String
ReDim NewTcode1ID(TransLines) As String
ReDim NewTcode2ID(TransLines) As String
ReDim NewTcode3ID(TransLines) As String
ReDim NewTcode4ID(TransLines) As String
ReDim NewTcode5ID(TransLines) As String
I = 1
For I = 1 To TransLines
OldAcctID(I) = ""
NewAcctID(I) = ""
Next I
End Sub
Sub File_Access()
' Open Account Mapping and input the data from
' columns which contain the old and
' new data for the account mappings
'
If MapHeader = 0 Then
I = 1
Else: I = 2
End If
Xl.Workbooks.Open MapLocation
Xl.ActiveWorkbook.RunAutoMacros xlAutoOpen
For I = 1 To TransLines
OldAcctID(I) = Cells(I, MapColumnLegacy)
NewAcctID(I) = Cells(I, MapColumnFE)
If Config_Form.MapProject_Check.Value = 1 Then
NewProjID(I) = Cells(I, MapColumnProject)
End If
If Config_Form.MapClass_Check.Value = 1 Then
NewClassID(I) = Cells(I, MapColumnClass)
End If
If Config_Form.MapTcode1_Check.Value = 1 Then
NewTcode1ID(I) = Cells(I, MapColumnTcode1)
End If
If Config_Form.MapTcode2_Check.Value = 1 Then
NewTcode2ID(I) = Cells(I, MapColumnTcode2)
End If
If Config_Form.MapTcode3_Check.Value = 1 Then
NewTcode3ID(I) = Cells(I, MapColumnTcode3)
End If
If Config_Form.MapTcode4_Check.Value = 1 Then
NewTcode4ID(I) = Cells(I, MapColumnTcode4)
End If
If Config_Form.MapTcode5_Check.Value = 1 Then
NewTcode5ID(I) = Cells(I, MapColumnTcode5)
End If
Next I
Xl.ActiveWorkbook.Close False
Xl.Quit
End Sub
Sub OpenExcelfile()
Xl.Workbooks.Open (TransLocation)
ActiveWorkbook.Sheets(ConvertSheet).Activate
Xl.Visible = True
'Opens transaction document to insert columns
Call LegacyAttribute
'Insert a new Column for Attribute and renames it, renames Legacy account header as Attribute Type
Call InsertNewAccount
'Insert a new Column for FE account and renames it
Call InsertNewProject
'Insert a new Column for Project and renames it
Call InsertNewClass
'Insert a new Column for Class and renames it
Call InsertNewTcode1
'Insert a new Column for Tcode1 and renames it
Call InsertNewTcode2
'Insert a new Column for Tcode2 and renames it
Call InsertNewTcode3
'Insert a new Column for Tcode3 and renames it
Call InsertNewTcode4
'Insert a new Column for Tcode4 and renames it
Call InsertNewTcode5
'Insert a new Column for Tcode5 and renames it
Call PlugInNewAcctIDs
'save the file
Xl.ActiveWorkbook.Save
'close the file
Xl.ActiveWorkbook.Close
Xl.Quit
Convertwait_Form.Hide
Unload Convertwait_Form
MsgBox "Your Accounts Have Been Converted", vbExclamation, "Conversion Complete"
'get the next file
End Sub
Sub PlugInNewAcctIDs()
' Go back to the main XL document and
' plug in the new account numbers when a match
' to the old number is found in the first column
'
Convertwait_Form.Show
BadCell = Cells(I, 2)
I = 1
J = 1
For I = 1 To TransLines
If (Cells(I, 1) = "") And (Cells(I + 1, 1) = "") And (Cells(I + 2, 1) = "")Then
GoTo Continue
Else
For J = 1 To TransLines
If Cells(I, 1) = OldAcctID(J) Then
Cells(I, 2) = "Legacy Account"
Cells(I, 3) = NewAcctID(J)
If Config_Form.MapProject_Check.Value = 1 Then
Cells(I, 4) = NewProjID(J)
End If
If Config_Form.MapClass_Check.Value = 1 Then
Cells(I, 5) = NewClassID(J)
End If
If Config_Form.MapTcode1_Check.Value = 1 Then
Cells(I, 6) = NewTcode1ID(J)
End If
If Config_Form.MapTcode2_Check.Value = 1 Then
Cells(I, 7) = NewTcode2ID(J)
End If
If Config_Form.MapTcode3_Check.Value = 1 Then
Cells(I, 8) = NewTcode3ID(J)
End If
If Config_Form.MapTcode4_Check.Value = 1 Then
Cells(I, 9) = NewTcode4ID(J)
End If
If Config_Form.MapTcode5_Check.Value = 1 Then
Cells(I, 10) = NewTcode5ID(J)
End If
End If
If Cells(I, 3) = "" Then
Cells(I, 3) = "Missing Account Mapping"
End If
Next J
End If
If Cells(I, 3) = "Missing Account Mapping" Then
Cells(I, 3).Interior.ColorIndex = 44
Cells(I, 3).Font.Color = vbRed
End If
Next I
Continue:
End Sub
Here is how to do what is recommended in the comments...
Change your AcctConv_Main() routine to this:
Sub AcctConv_Main()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Call CleanUp
Call File_Access
Call OpenExcelfile
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
First off thank you very much. Over the last few months (i believe) my coding has progressed drastically. Any and all criticize is always welcome (rip me apart).
Recently I started to try to use different Subs (I dont quite understand when to use functions etc, but i figure it is good structure practice for when i figure it out.
I am hitting a Run-time 424 Error with the following bit of code in Sub ownerCHECK
Sub OccupationNORMALIZATION()
Dim infoBX As String
' initialize variables
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
Do While infoBX = ""
infoBX = InputBox("Enter Occupation Column", "Occupation Column")
Loop
restaurCHECK (infoBX)
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub
-
Sub restaurCHECK(infoBX As String)
Dim RestaurantS(), RestaurantDQs() As Variant
Dim i, LRow, LCol, STATUScounter As Long
Dim rRng As Range
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
RestaurantS = Array("estaur", "food", "cafe", "beverage", "waiter", "waitr", _
"waitstaff", "wait staff", "grill") 'array list of target occupations
RestaurantDQs = Array("fast", "pub", "import", "packing", "processing", "packag", _
"retired", "anufact", "distrib") ' disqualifying words for Restaurante category
Set rRng = Range(infoBX & "2:" & infoBX & LRow)
Application.ScreenUpdating = False
For Each cell In rRng
ownerCHECK (cell)
For i = LBound(RestaurantS) To UBound(RestaurantS)
If InStrRev(cell.Value, UCase(RestaurantS(i))) > 0 Then
cell.Offset(, 1) = "Restaurants"
cell.Interior.Color = 52479
End If
Debug.Print cell.Value
Next
For i = LBound(RestaurantDQs) To UBound(RestaurantDQs)
If InStrRev(cell.Value, UCase(RestaurantDQs(i))) And cell.Interior.Color = 52479 Then
cell.Interior.Color = 255
cell.Offset(, 1) = ""
End If
Next
STATUScounter = STATUScounter - 1
Application.StatusBar = "REMAINING ROWS " & STATUScounter & " tristram "
Next cell
End Sub
-
Sub ownerCHECK(str_owner As Range)
Dim owner() As Variant
owner() = Array("owner", "shareholder", "owns ")
For i = LBound(owner) To UBound(owner)
If InStrRev(str_owner, UCase(owner(i))) > 0 Then
cell.Offset(, 2) = "Owner"
End If
Next
End Sub
I can see a couple of issues in ownerCHECK():
"cell" is not defined (unless it's global)
you shouldn't use "cell" as a variable name (internal VBA property)
check validity of incoming range
.
Option Explicit
Sub ownerCHECK(ByRef rngOwner As Range)
If Not rngOwner Is Nothing Then
Dim owner() As Variant
owner() = Array("OWNER", "SHAREHOLDER", "OWNS ")
For i = LBound(owner) To UBound(owner)
If InStrRev(UCase(rngOwner), owner(i)) > 0 Then
rngOwner.Offset(, 2) = "Owner"
End If
Next
End If
End Sub