I want to compare the content of two ranges in a worksheet to two strings on another worksheet. In the case of both conditions are met, the cell next to it has to be summes up with all prior matches.
The code that works fine with comparing it to one criteria:
Sub Makro1()
Dim FB As String
FB = ActiveWorkbook.Sheets("Form").Range("B3").Value
Dim MyRangeA As Range
Dim A As Range
Dim MyTotal As Long
Dim LastRow As Long
MyTotal = 0
LastRow = ActiveWorkbook.Sheets("Downloads").Cells(Cells.Rows.Count, "F").End(xlUp).Row
Set MyRangeA = ActiveWorkbook.Sheets("Downloads").Range("F3:F" & LastRow)
For Each A In MyRangeA
If A.Value = FB Then
MyTotal = MyTotal + A.Offset(, 1).Value
End If
ActiveWorkbook.Sheets("Downloads").Range("K3") = MyTotal
Next
End Sub
However, I just cannot figure out how to insert another criteria to my range. This is my current try that doesn't work:
Sub Macro1()
Dim FB As String
Dim MTH As String
FB = ActiveWorkbook.Sheets("Form").Range("B3").Value
MTH = ActiveWorkbook.Sheets("Form").Range("B5").Value
Dim MyRangeA As Range
Dim A As Range
Dim MyRangeB As Range
Dim B As Range
Dim MyTotal As Long
Dim LastRow As Long
MyTotal = 0
LastRow = ActiveWorkbook.Sheets("Downloads").Cells(Cells.Rows.Count, "F").End(xlUp).Row
Set MyRangeA = ActiveWorkbook.Sheets("Downloads").Range("F3:F" & LastRow)
Set MyRangeB = ActiveWorkbook.Sheets("Downloads").Range("D3:D" & LastRow)
For Each A In MyRangeA
For Each B In MyRangeB
If B.Value = MTH Then
MyTotal = MyTotal + A.Offset(, 1).Value
End If
Next
ActiveWorkbook.Sheets("Downloads").Range("L3") = MyTotal
Next
End Sub
Can anyone help my out with this one?
As Charles Williams wrote you could use SUMIFS. You can use it within your VBA routine if you are happy with case insensitive matching:
MyTotal = WorksheetFunction.SumIfs(MyRangeA.Offset(, 1), MyRangeA, FB, MyRangeB, MTH)
Or, if that is problematic, you could loop testing each item. However, depending on the size of your data, it is usually measurably faster to read everything into a VBA array, and loop through that, rather than going back to the worksheet for each item. In addition, it is generally faster to iterate by index For I = 1 to n ... Next I than to go through a For Each Someobject ... Next Someobject type of iteration. So if you did not want to use the above, I would try a code snippet similar to:
Dim I As Long
Dim vData As Variant
vData = Union(MyRangeA, MyRangeA.Offset(, 1), MyRangeB)
For I = 1 To UBound(vData)
If vData(I, 1) = FB And vData(I, 3) = MTH Then
MyTotal = MyTotal + vData(I, 2)
End If
Next I
Depending on your requirements, you might also, for the latter, consider adding
Option Compare Text
to the top of your macro.
Related
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.
My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
For j = 1 To cnt1
If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
For c = 2 To 22
If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
Exit For
End If
If j = cnt1 Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
End If
Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
Let's simplify the task and do it step by step.
This is how the input in the two sheets can look like:
Then, we may consider reading these and saving them to an array:
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
This is the result in the third worksheet, all matching values are in a single row:
This is how the whole code looks like:
Sub CompareTwoRanges()
Dim rangeA As Range
Dim rangeB As Range
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
End Sub
Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:
Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
resultArray(i) = myValA
i = i + 1
End If
Next
Next
ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)
when you get cell value, it spends time.
so, you can target Range transfer 2d Variant
Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))
'Transfer
olderVariant = olderRange
For currentRow = 1 to UBound(olderVariant, 1)
'Loop
'if you want change real Cell value Or interior
'add row Or Col weight
if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
End if
Next currentRow
In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:
Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long
Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary1)
.Item(Ary1(r, 1)) = Empty
Next r
For r = 1 To UBound(Ary2)
If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
Next r
End With
I'm a bit surprised this has proven to be such a challenge. On sheet 1 I have the input which looks as follows:
Private Sub CommandButton1_Click()
erw = Sheet2.Cells(1, 1).CurrentRegion.Rows.Count + 1
'erw.Offset(1).EntireRow.Insert Shift:=xlDow
If Len(Range("c3")) <> 0 Then
Sheet2.Cells(erw, 1) = Range("c3")
Sheet2.Cells(erw, 2) = Range("c4")
Sheet2.Cells(erw, 3) = Range("c5")
Range("c3") = ""
Range("c4") = ""
Range("c5") = ""
Else
MsgBox "You must enter an amount"
End If
End Sub
No issues with the above, where I'm running into a problems is with the following on sheet 2 where the information is stored:
Sub AddUp()
Dim rngcount As Long
Dim TotalA As Long
Dim rng2 As Range
rngcount = Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = Range("A28")
TotalA = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets("sheet2").Range("a1:a" & rngcount))
rng2 = TotalA
The real issue is the following Set rng2 = Range("A28") as this is essentially a cheat I've been using. I know that there will not be more than 26 entries to be summed and then a new sheet will be started. I currently have the TotalA amount Set to be put in A28, but what I am trying to do is have the TotalA cell move down as more entries are put in. Put another way I would rather the range where TotalA will be able to move as more entries are put in.
I began with the following erw.Offset(1).EntireRow.Insert Shift:=xlDowbut I moved away from that as the insertion of a row needs to occur on sheet2I've left it here for this posting in case there is any valuable feed back.
What I've been focusing on instead is trying to use CurrentRegion.offset(1) to keep moving the cell that holds the sum function down. Problem is I cannot figure out how to declare a range based on rngcount This may be the problem because perhaps I should not be using rngcount as it is not an object, but my thinking is/was that I could turn that rngcount into an object and then use CurrentRegion.offset(1) A bit long winded, hope the goal comes through clearly. Thanks
Take a look at this and see if it does what you want.
Sub AddUp()
Dim rngcount As Long
Dim TotalA As Long
Dim rng2 As Range
rngcount = Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = Cells(rngcount + 1, 1)
TotalA = Application.WorksheetFunction.Sum(ThisWorkbook.Sheets("sheet2").Range("a1:a" & rngcount))
rng2 = TotalA
End Sub
I usually like to put total formulas in the worksheet instead of doing the math in the macro.
Sub AddUp()
Dim rngcount As Long
Dim TotalA As Long
Dim TotalStartRng As Range
Dim TotalEndRng As Range
rngcount = Cells(Rows.Count, "A").End(xlUp).Row
Set TotalStartRng = Cells(1, 1)
Set TotalEndRng = Cells(rngcount, 1)
Cells(rngcount + 1, 1) = "=SUM(" & TotalStartRng.Address & ":" & TotalEndRng.Address & ")"
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True
I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub
Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub