My dataset is like this
I want to make them
Please look at the first row.
My code is
Private Sub CommandButton1_Click()
Dim MyColInstance, i As Long
Dim MyWorksheetLastColumn As Byte
MyWorksheetLastColumn = Worksheets(1).Cells(1, columns.Count).End(xlToLeft).Column
For i = 1 To MyWorksheetLastColumn
MyColInstance = ColInstance("Preference", i)
Cells(1, MyColInstance).Value = "Preference" & i
Next i
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).Column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function
The problem is while running this code, it shows an error because the for loop is not complete. What can we do?
Can you do it this way? It seems to me you are just adding a suffix to your headers in the first row...
Sub UpdateColumnHeaders()
Dim headers As Range, header As Range, suffixes As Range, suffix As Range, i As Integer
Set headers = Range(Cells(1, 1), Cells(1, Range("A1").End(xlToRight).Column))
Set suffixes = Range("A1:A" & Range("A1").End(xlDown).Row)
i = 1
For Each header In headers
If header = "Preferences" Then
header = header & suffixes(i)
i = i + 1
End If
Next
End Sub
Private Sub CommandButton1_Click()
Dim Count1, Count2 As Integer
Dim MyWorksheetLastRow As Byte
Dim MyColInstance, emp_i As Long
For Each Row_Cel In Range("1:1")
If Row_Cel.Value = "Employment" Then
Count1 = Count1 + 1
End If
If Row_Cel.Value = "Job" Then
Count2 = Count2 + 1
End If
Next Row_Cel
For emp_i = 1 To Count1
MyColInstance = ColInstance("Employment", emp_i)
Cells(1, MyColInstance).Value = "Employment" & emp_i
Next emp_i
For emp_i = 1 To Count2
MyColInstance = ColInstance("Job", emp_i)
Cells(1, MyColInstance).Value = "Job" & emp_i
Next emp_i
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).Column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function
Related
My loop seems to create infinite rows and is bugging
For Each Cell In Workbooks(newBook).Sheets(1).Range("A1:A" & lRow)
Checker = Cell.Value
For Counter = 1 To Len(Checker)
If Mid(Checker, Counter, 1) = vbLf Then
holder = Right(Mid(Checker, Counter, Len(Checker)), Len(Checker))
Workbooks(newBook).Sheets(1).Range(Cell.Address).EntireRow.Insert
End If
Next
Next Cell
Use a reverse loop. For i = lRow to 1 Step -1. Also to separate word, you can use SPLIT().
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim Ar As Variant
'~~> Change this to the relevant worksheet
Set ws = Sheet2
With ws
'~~> Find last row in Column A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Reverse Loop in Column A
For i = lRow To 1 Step -1
'~~> Check if cell has vbLf
If InStr(1, .Cells(i, 1).Value, vbLf) Then
'~~> Split cell contents
Ar = Split(.Cells(i, 1).Value, vbLf)
'~~> Loop through the array from 2nd position
For j = LBound(Ar) + 1 To UBound(Ar)
.Rows(i + 1).Insert
.Cells(i + 1, 1).Value = Ar(j)
Next j
'~~> Replace cells contents with content from array from 1st position
.Cells(i, 1).Value = Ar(LBound(Ar))
End If
Next i
End With
End Sub
BEFORE
AFTER
This is my solution, works with 2 dimensional ranges as well and it works on Selection, so select the range with the cells you want to split and run the code.
Sub splitByNewLine()
Dim pasteCell As Range, rowCumulationTotal As Integer
rowCumulationTotal = 0
Dim arr() As Variant
arr = Selection
Selection.Clear
For i = 1 To UBound(arr)
Dim rowCumulationCurrent As Integer, maxElemsOnRow As Integer
rowCumulationCurrent = 0
maxElemsOnRow = 0
For j = 1 To UBound(arr, 2)
Dim elems() As String, elemCount As Integer
elems = Split(arr(i, j), vbLf)
elemCount = UBound(elems)
For k = 0 To elemCount
Cells(Selection.Row + i + rowCumulationTotal + k - 1, Selection.Column + j - 1) = elems(k)
If maxElemsOnRow < k Then
rowCumulationCurrent = rowCumulationCurrent + 1
maxElemsOnRow = k
End If
Next k
Next j
rowCumulationTotal = rowCumulationTotal + rowCumulationCurrent
Next i
Exit Sub
End Sub
Input:
Output:
I need to check if each string in arr1 has a match in arr2.
If it has a match then write "Match" to the column next to arr1, if not then "Not Match".
Here's how my sheet looks:
Sub Variant_Array_Question()
'Here is my frankenstein monster of a code
Dim DocNm As Variant, NroNm As Variant
Dim i As Long, j As Long
Dim NroLastRow As Long, DocLastRow As Long
'Arr1
DocLastRow = ShStart.Range("Q" & Rows.Count).End(xlUp).Row
DocNm = ShStart.Range("Q6:Q" & DocLastRow).Value
'Arr2
NroLastRow = ShStart.Range("T" & Rows.Count).End(xlUp).Row
NroNm = ShStart.Range("T6:T" & NroLastRow).Value
For i = 1 To UBound(DocNm)
For j = 1 To UBound(NroNm)
If DocNm(i, 1) = NroNm(j, 1) Then
'Match was found ==== Run into Problem here
DocNm(i, 1).Offset(0, 1).Value = "Match"
Exit For
End If
Next j
If i > UBound(NroNm) Then
'No match was found ==== Run into Problem here
DocNm(i, 1).Offset(0, 1).Value = "Not Match"
End If
Next i
End Sub
DocNm(i, 1).Offset(0, 1).Value = "Match" has no meaning for an array. An array do not have an Offset property.
If your sheet example is real in terms of ranges size, use Ranges instead of arrays.
In order to use arrays and obtain the result you need you must use a third array. Dimension it as your first array Ubound, but I will better transform your code:
Sub Variant_Array_Question()
Dim DocNm As Variant, NroNm As Variant, arrStat As Variant
Dim i As Long, j As Long, boolFound As Boolean
Dim NroLastRow As Long, DocLastRow As Long
Dim ShStart As Worksheet
Set ShStart = ActiveSheet 'use here your sheet!!!
'Arr1
DocLastRow = ShStart.Range("Q" & Rows.Count).End(xlUp).Row
DocNm = ShStart.Range("Q6:Q" & DocLastRow).value
ReDim arrStat(1 To UBound(DocNm, 1), 1 To 1) 'arr 3
'Arr2
NroLastRow = ShStart.Range("T" & Rows.Count).End(xlUp).Row
NroNm = ShStart.Range("T6:T" & NroLastRow).value
For i = 1 To UBound(DocNm)
For j = 1 To UBound(NroNm)
If DocNm(i, 1) = NroNm(j, 1) Then
boolFound = True
arrStat(i, 1) = "Match"
Exit For
End If
Next j
If Not boolFound Then
arrStat(i, 1) = "Not Match"
End If
boolFound = False
Next i
ShStart.Range("R6").Resize(UBound(arrStat, 1), 1).value = arrStat
End Sub
Not tested, but I think it will work. If you would supply an editable example, I would test it...
Here's the code that FaneDuru helped me solve. This goes for those noobs in need like me.
Sub Variant_Array_Response()
Dim DocNm As Variant, NroNm As Variant, ResStatus As Variant
Dim i As Long, j As Long, boolFound As Boolean
Dim NroLastRow As Long, DocLastRow As Long
Dim ShStart As Worksheet
Set ShStart = ActiveSheet
'Arr1
DocLastRow = ShStart.Range("Q" & Rows.Count).End(xlUp).Row
DocNm = ShStart.Range("Q6:Q" & DocLastRow).Value
'Arr2
NroLastRow = ShStart.Range("T" & Rows.Count).End(xlUp).Row
NroNm = ShStart.Range("T6:T" & NroLastRow).Value
'Arr3
'ResStatus = ShStart.Range("Q6:Q" & DocLastRow).Offset(, 1) 'What I had
ReDim ResStatus(1 To UBound(DocNm, 1), 1 To 1) 'FaneDuru's pice
For i = 1 To UBound(DocNm)
For j = 1 To UBound(NroNm)
If DocNm(i, 1) = NroNm(j, 1) Then
boolFound = True
ResStatus(i, 1) = "Match"
Exit For
End If
Next j
If Not boolFound Then
ResStatus(i, 1) = "Not Match"
End If
boolFound = False
Next i
ShStart.Range("R6").Resize(UBound(ResStatus, 1), 1).Value = ResStatus
End Sub
Background:
Was trying to come up with efficient ways to handle a large amount of tables on a single sheet and came across Jagged Arrays (herein "Jars").
To simply understand some basics of Jars, I was trying to build a simple scenario of staggered information to be able to create the Jar.
My Jar is labeled big_arr and each array inside is called lil_arr.
Here is the data for the scenario:
ColA 'adding row number in front of each word
1 cat
2 dog
3
4 mouse
5 elephant
6
7 zebra
8 snake
9
10 cheese
11 pickle
12
13 anteater
14 mirkat
15
16 skunk
17 smurf
In the above scenario, big_arr(2) = lil_arr where `lil_arr = array("mouse","elephant").
I would then have big_arr(i) print to a sheet; the sheet is labeled as i, when looping. So sheet 2 would have cells(1,1).value = "mouse" and cells(1,2).value = "elephant".
Issue:
I am having issues getting the data to print as expected.
The exact printing that is happening (based on i as the sheet name):
1 has cells(1,1).value = 0
2 has cells(1,1).value = "skunk"
3 has cells(1,1).value = 0
4 has cells(1,1).value = 0
5 has cells(1,1).value = 0
6 has cells(1,1).value = 0
I don't seem to be able to print using Application.Transpose(big_arr(i)). I have attempted to loop, but don't seem to have appropriate syntax.
Question:
Any help to resolve the issue with Application.Transpose(), which does not trigger an error message, would be appreciated.
Otherwise, help to get the loop to work with appropriate syntax would be phenomenal.
Code in question:
Code with Application.Transpose() for printing
Sub create_jagged_array_of_tables()
Dim big_arr As Variant, lil_arr As Variant, lr As Long, i As Long, j As Long, k As Long, ws As Worksheet
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim big_arr(1 To lr)
For i = 1 To lr
j = 1
Do Until IsEmpty(Cells(i + j, 1))
j = j + 1
Loop
If j > 1 Then
lil_arr = Cells(i, 1).Resize(j).Value
big_arr(j) = lil_arr
i = i + j
k = k + 1
Else
MsgBox "row " & i & " is not part of an array"
End If
Next i
For i = 1 To k
Set ws = Sheets.Add
ws.Name = i
Cells(1, 1).Value = Application.Transpose(big_arr(i))
Next i
End Sub
Code for the loop I attempted, giving type-mismatch, focusing only on the for i = 1 to k loop:
For i = 1 To k
Set ws = Sheets.Add
ws.Name = i
'Cells(1, 1).Value = Application.Transpose(big_arr(i))
For j = 1 To UBound(big_arr(i), 1)
Cells(j, 1).Value = big_arr(i)(j)
Next j
Next i
In this case j will always = 2 at the line:
big_arr(j) = lil_arr
so you keep overwriting that.
I assume you want to use k instead of j for the counter of big_arr:
big_arr(k) = lil_arr
But that will require you to have a k=1 before the i loop.
Also you need to resize the output to the size of the lil_array:
Sub create_jagged_array_of_tables()
Dim big_arr As Variant, lil_arr As Variant, lr As Long, i As Long, j As Long, k As Long, ws As Worksheet
lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim big_arr(1 To lr)
k = 0
For i = 1 To lr
j = 1
Do Until IsEmpty(Cells(i + j, 1))
j = j + 1
Loop
If j > 1 Then
lil_arr = Cells(i, 1).Resize(j).Value
k = k + 1
big_arr(k) = lil_arr
i = i + j
Else
MsgBox "row " & i & " is not part of an array"
End If
Next i
For i = 1 To k
Set ws = Sheets.Add
ws.Name = i
Cells(1, 1).Resize(1, UBound(big_arr(i), 1)).Value = Application.Transpose(big_arr(i))
Next i
End Sub
Did just a little tweaking and it's working for me:
Sub create_jagged_array_of_tables()
Dim big_arr As Variant, lil_arr As Variant, lr As Long, i As Long, j As Long, k As Long, ws As Worksheet
lr = Cells(Rows.Count, 1).End(xlUp).Row
Dim big_arr_size As Long
' Assumes you have groups of 2 per small array
big_arr_size = WorksheetFunction.CountA(Range("A1:A" & lr)) / 2
ReDim big_arr(1 To big_arr_size)
k = 1
For i = 1 To lr
j = 1
Do Until IsEmpty(Cells(i + j, 1))
j = j + 1
Loop
If j > 1 Then
lil_arr = Cells(i, 1).Resize(j).Value
big_arr(k) = lil_arr ' changed `j` to `k`
i = i + j
k = k + 1
Else
MsgBox "row " & i & " is not part of an array"
End If
Next i
For i = 1 To big_arr_size
Set ws = Sheets.Add
ws.Name = i
ws.Cells(1, 1).Value = big_arr(i)(1, 1)
ws.Cells(1, 2).Value = big_arr(i)(2, 1)
Next i
End Sub
Edit: Here's a perhaps different way you can do this. It avoids using a "small array" to set as part of a larger array.
Sub t()
Dim big_arr As Variant
Dim lr As Long
lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Dim big_arr_size As Long
' Assumes you have groups of 2 per small array
big_arr_size = WorksheetFunction.CountA(Range("A1:A" & lr)) / 2
ReDim big_arr(1 To lr)
big_arr = Range("A1:A" & lr).Value
Dim i As Long, wsName As Long
Dim ws As Worksheet
wsName = LBound(big_arr)
For i = LBound(big_arr) To UBound(big_arr) - 1
If Not IsEmpty(big_arr(i, 1)) And Not IsEmpty(big_arr(i + 1, 1)) Then
Set ws = Sheets.Add
ws.Name = wsName
ws.Cells(1, 1).Value = big_arr(i, 1)
ws.Cells(1, 2).Value = big_arr(i + 1, 1)
wsName = wsName + 1
End If
Next i
End Sub
The Post already had two brilliant answers (one accepted) and both have there unique characteristics. But just want to share some of my idea since I find the the post highly interesting. I just tried to simplify the creation of jagged array using single loop using a flag and avoided transpose. May please not taken as contravention.
Sub create_jagged_array_of_tables()
Dim big_arr() As Variant, lil_arr As Variant, lr As Long, i As Long, j As Long, k As Long, ws As Worksheet
Dim Nw As Boolean, Xval As Variant
lr = Cells(Rows.Count, 1).End(xlUp).Row
k = 0
j = 0
For i = 1 To lr
Xval = Cells(i, 1).Value
If IsEmpty(Xval) = False Then
If Nw = False Then
Nw = True
k = k + 1
j = 1
ReDim lil_arr(1 To 1, 1 To j)
lil_arr(1, j) = Xval
ReDim Preserve big_arr(1 To k)
big_arr(k) = lil_arr
Else
j = j + 1
ReDim Preserve lil_arr(1 To 1, 1 To j)
lil_arr(1, j) = Xval
big_arr(k) = lil_arr
End If
Else
Nw = False
End If
Next i
For i = 1 To k
Set ws = Sheets.Add
ws.Name = i
Cells(1, 1).Resize(1, UBound(big_arr(i), 2)).Value = big_arr(i)
Next i
End Sub
And if creation of jagged Array is not required and sole objective is to copy the content in the desired fashion, the it could be further simplified to
Sub test1()
Dim lr As Long, Rng As Range, Area As Range, Cnt As Long, Arr As Variant
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A1:A" & lr)
Rng.AutoFilter Field:=1, Criteria1:="<>"
Set Rng = Rng.SpecialCells(xlCellTypeVisible)
Cnt = 0
For Each Area In Rng.Areas
Cnt = Cnt + 1
Set ws = Sheets.Add
ws.Name = Cnt
Arr = Area.Value
If IsArray(Arr) Then
ws.Cells(1, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)).Value = Application.Transpose(Arr)
Else
ws.Cells(1, 1).Value = Arr
End If
Next
Rng.AutoFilter Field:=1
End Sub
I want to have alternate backgrd colour for different text
I wrote a code for it and there are several errors. How can I improve it? Thanks
Sub Alternatecolour()
Flag = True
lr = Cells(Rows.Count, 1).End(xlUp).Row
Startcl = Cells(2, "D")
For Each cl In Range("D2:D" & lr)
str1 = cl.Text
str2 = cl.Offset(-1, 0).Text
Diff = StrComp(str1, str2, vbBinaryCompare)
If Diff = 0 Then
GoTo Loopend
End If
If Diff <> 0 Then
If Flag = True Then
Range(Startcl, cl).Interior.Color = 15
Startcl = cl
Flag = False
Else
Range(Startcl, cl).Interior.Color = 16
Startcl = cl
Flag = True
End If
End If
Loopend
Next cl
End Sub
I suggest the following code:
Public Sub AlternateColor()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("ColorMe")
Dim ColorRange As Range
Set ColorRange = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp))
Dim StartRow As Long
StartRow = ColorRange.Row
Dim ActColor As Long
ActColor = 15
Dim iRow As Long
For iRow = ColorRange.Row To ColorRange.Rows.Count + ColorRange.Row - 1
If ws.Cells(iRow, "D").Value <> ws.Cells(iRow, "D").Offset(1, 0).Value Then
ws.Range(ws.Cells(StartRow, "D"), ws.Cells(iRow, "D")).Interior.ColorIndex = ActColor
ActColor = IIf(ActColor = 15, 16, 15)
StartRow = iRow + 1
End If
Next iRow
End Sub
I've been struggling with this for a few days. Any help would greatly be appreciated!
It's difficult to explain, so I'll do my best.
What I'm trying to do is count the number of results each query has and then categorize them based on that result count.
For example if Query_A has 1 exact result and then Query_Z has 1 exact result then that would be a total of 2 queries that have 1 result.
I'm currently trying to use Loop with if then statements, but I'm at a loss.
Here is some example data and the output I was hoping for: Query_Example_Data_and_Results.xlsx - This is not my real spreadsheet as it is thousands of rows of data and a very large file size.
The code below does pull the query count (removing the query dupes), but does not give the query result count.. I would have provide my code attempts, but I know I'm not even close... So I have removed my failed attempts hoping I'm being clear enough to get steered in the right direction.
Sub Query_Count()
G_40 = 0
Query = ""
Application.StatusBar = " ~~ ~~ QUERY COUNT ~~ RUNNING ~~ ~~ " & x
x = 2
Do Until Sheets(1).Cells(x, 1) = ""
If Sheets(1).Cells(x, 9) = "Yes" Then
If Query <> Sheets(1).Cells(x, 1) Then
G_40 = G_40 + 1
End If
End If
Query = Sheets(1).Cells(x, 1)
x = x + 1
Loop
Application.StatusBar = "DONE RUNNING QUERY COUNT OF " & x & " ROWS!"
G = 40
Sheets(3).Cells(G, 7) = G_40 'query_count:
End Sub
Thank you in advance!
Based on your Example this code will do the job:
Option Explicit
Sub getResults()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, lr&
Set ws1 = ThisWorkbook.Sheets("Example_Query_Data")
Set ws2 = ThisWorkbook.Sheets("Example_Results")
lr = ws1.Range("A" & Rows.count).End(xlUp).Row
Dim arr() As String, i&, j&, cnt&
Dim varr() As String
cnt = 0
ReDim arr(lr - 2)
For i = 2 To lr
arr(i - 2) = CStr(ws1.Range("A" & i).Value) ' fill array
Next i
Call RemoveDuplicate(arr) 'remove duplicate
ReDim varr(0 To UBound(arr), 0 To 1)
For i = LBound(arr) To UBound(arr)
varr(i, 0) = arr(i)
varr(i, 1) = getCount(arr(i), ws1, j, lr)
Next i
Call PrepTable(ws2)
Call UpdateTable(ws2, ws1, varr, j, lr) ' Update table
Application.ScreenUpdating = True
End Sub
Function getCount(qName$, ByRef ws1 As Worksheet, ByRef i&, lr&)
Dim count&
count = 0
For i = 2 To lr
If (StrComp(CStr(ws1.Range("A" & i).Value), qName, vbTextCompare) = 0) And _
(StrComp(CStr(ws1.Range("C" & i).Value), "Yes", vbTextCompare) = 0) Then count = count + 1
Next i
getCount = count ' return count
End Function
Sub UpdateTable(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, ByRef i&, lr&)
Dim tblIter&
For tblIter = 2 To 12
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = tblIter - 1 Then
ws.Range("B" & tblIter).Value = ws.Range("B" & tblIter).Value + 1
End If
Next i
Next tblIter
Call ElevenAndMore(ws, ws2, arr, lr, i)
End Sub
Sub PrepTable(ws As Worksheet)
ws.Range("B2:B12").ClearContents
End Sub
Sub ElevenAndMore(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, lr&, ByRef i)
Dim cnt&, j&
cnt = 0
For i = LBound(arr) To UBound(arr)
For j = 1 To lr
If StrComp(CStr(ws2.Range("A" & j).Value), arr(i, 0), vbTextCompare) = 0 Then
cnt = cnt + 1
End If
Next j
If cnt > 10 Then ws.Range("B12").Value = ws.Range("B12").Value + 1
cnt = 0
Next i
End Sub
Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub ' is empty?
lowBound = LBound(StringArray)
UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound ' first item
tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B: tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur) ' reSize
StringArray = tempArray ' copy
End Sub
Post-Comment Edit:
Change these three:
Add +28 to the tblIter
Sub UpdateTable(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, ByRef i&, lr&)
Dim tblIter&
For tblIter = 2 To 12
For i = LBound(arr) To UBound(arr)
If arr(i, 1) = tblIter - 1 Then
ws.Range("B" & tblIter + 28).Value = ws.Range("B" & tblIter + 28).Value + 1
End If
Next i
Next tblIter
Call ElevenAndMore(ws, ws2, arr, lr, i)
End Sub
Simply change location to B40
Sub ElevenAndMore(ByRef ws As Worksheet, ByRef ws2, ByRef arr() As String, lr&, ByRef i)
Dim cnt&, j&
cnt = 0
For i = LBound(arr) To UBound(arr)
For j = 1 To lr
If StrComp(CStr(ws2.Range("A" & j).Value), arr(i, 0), vbTextCompare) = 0 Then
cnt = cnt + 1
End If
Next j
If cnt > 10 Then ws.Range("B40").Value = ws.Range("B40").Value + 1
cnt = 0
Next i
End Sub
And prep table change range
Sub PrepTable(ws As Worksheet)
ws.Range("B30:B40").ClearContents
End Sub
and this should do!