Generate Sum Total in form of "=xxx+xxx..." - excel

I have a problem for the below code - it cannot generate the result to "=XXX+XXX+XXX+XXX" (XXX = number)
is it anything wrong ?
There are 3 parts
Part A : Add comment <---run properly
Part B : Add username/editor's name into comment <---run properly
Part C : show the sum total but in form of "=xxx+xxx+xxx+xxx" not "=Sum(yyy:zzz)" <---no error but no result
Column F is Sum total and Row 9 is items name, Range I10 to last row and last column is a table, but last row and column is variable
Option Explicit
Public Sub AddComments()
Dim ws As Worksheet: Set ws = ActiveSheet 'sheet select
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Dim lCol As Long: lCol = ws.Cells(9, ws.Columns.Count).End(xlToLeft).Column
Dim srg As Range: Set srg = ws.Range("A1").Resize(lRow, lCol) 'Used area
Dim Data As Variant: Data = srg.Value 'value in used area
Dim r As Long, c As Long, n As Long
Dim Comm As String
Dim fitcomment As Comment
For r = 22 To lRow
For c = 9 To lCol
If Len(Data(r, c)) > 0 Then
n = n + 1
Comm = Comm & n & ". " & Data(9, c) & " -" _
& Format(Data(r, c), "$#,##0") & vbLf
End If
Next c
If n > 0 Then
With srg.Cells(r, 6)
.ClearComments
.AddComment Left(Comm, Len(Comm) - 1)
End With
n = 0
Comm = ""
End If
Next r
For Each fitcomment In Application.ActiveSheet.Comments 'Add User Name
fitcomment.Text Text:=Environ$("Username") & vbLf, Start:=1, Overwrite:=False
fitcomment.Shape.TextFrame.Characters(1, Len(Environ$("UserName"))).Font.Bold = True
fitcomment.Shape.TextFrame.AutoSize = True
Next
For r = 22 To lRow
c = 9
Comm = "="
Do
If ws.Cells(r, c).Value <> "" And IsNumeric(ws.Cells(r, c)) And ws.Cells(r, c).Value <> 0 Then
Comm = Comm & "+" & ws.Cells(r, c).Value
End If
c = c + 1
Loop While Not (c > ws.UsedRange.Columns.Count)
If Comm <> "=" Then
ws.Cells(6, r).Value = Comm
Else
ws.Cells(6, r).Value = ""
End If
Next r
MsgBox "Comments added.", vbInformation
End Sub

It looks like you've transposed the row/column arguments for ws.Cells when writing the Comm result.
The code is generating a formula string, but it is being written to row 6 starting in column 22('V'). Cell V6 is probably beyond the columns displayed on you monitor - which explains why it looks like there is no output.
If Comm <> "=" Then
ws.Cells(6, r).Value = Comm
Else
ws.Cells(6, r).Value = ""
End If
Should be:
If Comm <> "=" Then
ws.Cells(r, 6).Value = Comm
Else
ws.Cells(r, 6).Value = ""
End If
BTW, the summation String that you are generating is of the form "=+XXX+XXX+XXX". Excel is fixing this up for you to be "=XXX+XXX+XXX".

Related

i want to get the frequency of a data in a column using vba

i tried using dictionary but it only counts the repetition but i want to know the exact frequency of all datas in a column
what ive used is
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll
End Sub
and this gives me
[1: https://i.stack.imgur.com/Mhp5g.png][1]
but what i need is
[4: https://i.stack.imgur.com/UYOFu.png][4]
I think this is what you were after. Please try it.
Sub CountThings()
Dim Ws As Worksheet
Dim Items As Object ' Scripting.Dictionary
Dim Arr As Variant ' values in column B
Dim R As Long ' loop couner: Rows
Dim Key As Variant ' loop counter: dictionary keys
Set Items = CreateObject("Scripting.Dictionary")
Set Ws = ActiveSheet ' better: define tab by name
With Ws
' reading from the sheet is slow
' therefore read all items at once
Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
' this is a 1-based 2-D array, like Arr([Rows], [Column])
' where column is always 1 because there's only 1 column
End With
For R = 1 To UBound(Arr)
If Items.Exists(Trim(Arr(R, 1))) Then
Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
Else
Items.Add Trim(Arr(R, 1)), 1
End If
Next R
ReDim Arr(1 To Items.Count, 1 To 2)
R = 0
For Each Key In Items.keys
R = R + 1
Arr(R, 1) = Key
Arr(R, 2) = Items(Key)
Next Key
' specify the top left cell of the target range
Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
Set Items = Nothing
End Sub
You need not Trim the Keys if you are sure that there can't be any stray leading or trailing blanks.
Your second picture doesn't need VBA. It can be produce by this formula, entered in C2 and copied down.
=COUNTIF($B$2:$B$13,$B2)
In fact, you can even do the job of my above code without VBA. Enter this formula in G2 of your sheet as an array formula (confirmed with CTL + SHIFT + ENTER if you don't have Excel 365), and the other one in H. Then copy both formulas down.
[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")
You need to assign values to column C after you have finished counting and therefore, need another loop:
Sub countThings()
Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
End If
Next x
For x = 2 To lastrow
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Next x
items.RemoveAll
Set items = Nothing
End Sub
A simpler way to achieve what you want is to let excel do the counting for you like this:
Sub countThings2()
Dim sDataAddress As String
With ActiveSheet
sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
With .Range(sDataAddress).Offset(0, 1)
.Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
.Value = .Value
End With
End With
End Sub
i use table and 2 functions. not simple way but works :)
Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range
int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)
For i = 1 To int_LastRow
str_Text = ActiveSheet.Range("A" & i)
If i > 1 Then
str_Result = IsInArray(str_Text, str_Tab)
If str_Result = -1 Then
int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
ReDim str_Tab(int_TabItemCounter)
str_Tab(int_TabItemCounter) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
Else
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If str_Result = -1
Else ' If i > 1
ReDim str_Tab(i)
str_Tab(i) = str_Text
ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
End If ' If i > 1
Next i
End Sub
function to check is text in table
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
function to count item in range
Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
LA = rng_FindRange.Address
CountThisItem = 1
Do
Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
Loop While rng_FindRange.Address <> LA
Else
CountThisItem = 0
End If
End Function

Copy value and paste under matching column near respective row

I have a column with certain values which are also the headers for some columns. I want to check where the column values match and paste the value from the first column into the column with the same column name. I have around 1200 values in the first column. I want to loop through those values and paste the matching values in the corresponding row.
[![Data][1]][1]
Here is my sheet with my data that I want to work on. How I want my final sheet to look like is as follows:
Weeks | W1 | W2 | W3 | W4 | W5 | W6
W1 W1
W3 W3
Any help for the same would be highly appreciated.
Sub Weeks()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Mas As Worksheet
Set Mas = Sheets("Master Sheet")
For i = 5 To 1200
If Mas.Range("B" & i) <> "" Then
If Mas.Range("AO" & i) = "Missing week" Then
Mas.Range("AV" & i) = ""
Mas.Range("AW" & i) = ""
Mas.Range("AX" & i) = ""
Mas.Range("AY" & i) = ""
Mas.Range("AZ" & i) = ""
Mas.Range("BA" & i) = ""
Else
For j = 5 To 1200
If Mas.Range("AO" & i) = "W1" Then
Mas.Range("AV" & j) = "W1"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W2" Then
Mas.Range("AW" & j) = "W2"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W3" Then
Mas.Range("AX" & j) = "W3"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W4" Then
Mas.Range("AY" & j) = "W4"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W5" Then
Mas.Range("AZ" & j) = "W5"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W6" Then
Mas.Range("BA" & j) = "W6"
GoTo Nexti
End If
Next j
End If
End If
Nexti:
Next i
End Sub
This is the code I tried so far but it does not show any output.
This is how you use the dictionary to achieve your goal:
Option Explicit
Sub Weeks()
Dim Mas As Worksheet: Set Mas = ThisWorkbook.Sheets("Master Sheet")
With Mas
'Calculate thelast row
Dim i As Long
Dim LastRow As Long: LastRow .Cells(.Rows.Count, "AO").End(xlUp).Row
'insert your data into an array
Dim arr As Variant: arr = .Range("AO5:BA" & LastRow).Value
'Generate a dictionary with the headers
'this needs the library Microsoft Scripting Runtime under Tools->References
Dim Headers As Dictionary: Set Headers = LoadHeaders(.Range("AO4:BA4").Value)
'Now loop through the array
For i = 1 To UBound(arr)
If Headers.Exists(arr(i, 1)) Then arr(i, Headers(arr(i, 1))) = arr(i, 1)
arr(i, 1) = vbNullString
Next i
.Range("AO5:BA" & LastRow).Value = arr
End With
End Sub
Private Function LoadHeaders(arr As Variant) As Dictionary
Set LoadHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
LoadHeaders.Add arr(1, i), i
Next i
End Function
You won't even need the Application.ScreenUpdating because it does only one operation in Excel, will take a second or two to end this procedure.
Place this code in a module and link it to a button on the sheet.
'data
Cells.Clear
wks = Array("W1", "W2", "W3", "W4", "W5", "W6", "Missing week")
For i = 1 To 30
Cells(i, 2) = wks(Int(Rnd * 7))
Next i
'code
Set weeks = [b:b]
For Each wk In weeks
If Len(wk) = 2 Then Cells(wk.Row, Right(wk, 1) + 2) = wk
Next wk
weeks contains the column that has the list of column headings. The For..Each statement loops through each entry in this list.
Then it checks each entries string length. If it is length 2, it assumes the entry is valid (i.e of the form 'Wx' with x between 1 and 6), and then uses the inbuilt Right function to find the value of x, and then adds the appropriate entry into the appropriate column.

Generate the number of "(x,y)" data in a cell with reference to a number

(eg: 1=(x1,y1), 3=(x1,y1,x2,y2,x3,y3)
How do i remove the unnecessary "(,)" as shown below and put the number of position of the x,y coordinates of the reliability fail with reference to the number under the header of reliability fails?
Eg: Reliability fail counts =2 in device WLR8~LW~VBD~MNW should give me the position of that fail counts at the same row as the device at columnX. Anyways please ignore the data under the V and W column in my pictures.
Current output based on my code
What i really want
Current issue
Current issue2
where it should be
Dim output As Variant
Dim outputrow As Integer
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
For ia = 2 To lastrow2
If ws1.Cells(ia, "U").Value = 0 Then
output = output & "(" & ws1.Cells(ia, "Y").Value & "," & ws1.Cells(ia, "Z").Value & "),"
ElseIf output = "(,)," Then 'if there are no x and y values in Y and Z column stop showing "(,),"
output = ""
End If
If ws1.Cells(ia, "U").Value > 0 Then
ws1.Cells(ia, "U").Offset(0, 3).Value = Left(output, Len(output) - 1) 'extract the x and y values obtain in (x,y) format
'if there is "value" under reliability fails(column U), put the x y position at the same row as the "value" at column X
End If
Next
End If
I suggest using an inner loop so that extra brackets don't get added in the first place
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(ia + ib - 1, "Y").Value & "," & ws1.Cells(ia + ib - 1, "Z").Value & ")"
If ib < valueCount Then output = output & ","
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
EDIT
Here is the amended code in light of OP's later example:
Option Explicit
Sub test()
Dim output As Variant
Dim outputrow As Integer
Dim valueCount As Long, ib As Long, rowPointer As Long
output = ""
outputrow = 0
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
Dim ia As Long
Dim lastrow2 As Long
lastrow2 = ws1.Range("U2:U" & ws1.Rows.Count).Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
If ws1.Range("U1") = "Reliability Fail" Then
rowPointer = 2
' Outer loop over all rows
For ia = 2 To lastrow2
valueCount = ws1.Cells(ia, "U").Value
output = ""
' Inner loop to process repeated rows
For ib = 1 To valueCount
output = output & "(" & ws1.Cells(rowPointer, "Y").Value & "," & ws1.Cells(rowPointer, "Z").Value & ")"
If ib < valueCount Then output = output & ","
rowPointer = rowPointer + 1
Next ib
ws1.Cells(ia, "U").Offset(0, 3).Value = output
Next ia
End If
End Sub
First, strip out the extra blank pairs using this:
output = Replace(Range("X" & lRow), ",(,)", "")
You should then have it down to just the pairs you want.
Then split it based on ), and append a ) if it doesnt end in one. Here is an example you can use to incorporate it in your code:
Sub test()
Dim lRow As Long
Dim vSplit As Variant
Dim sResult As String
Dim output as String
For lRow = 2 To 3
If Len(Range("X" & lRow)) > 0 And Val(0 & Range("U" & lRow)) > 0 Then
output = Replace(Range("X" & lRow), ",(,)", "") ' this strips out the extra empty pairs
vSplit = Split(output, "),") ' this creates a string array, 1 item for each pair
sResult = vSplit(Val(Range("U" & lRow)) - 1) ' this gets the one you want based on column U ( -1 because the Split array is 0 based)
If Right$(sResult, 1) <> ")" Then sResult = sResult & ")" ' this adds a ")" if one is missing
Debug.Print sResult ' debug code
Range("X" & lRow) = sResult ' this adds the result to column X, replacing what was there
End If
Next
End Sub

Expand Rows Based on Column

I am creating hierarchies and need to outline them in the format on the right-hand side. It would be a lot easier if I could simply outline the hierarchy in one column and automatically have it expand (left -> right in the sample).
A few considerations:
Within the first column, the start of a new hierarchy will always be the value 'A'
Hierarchies can range from 2-10 children in length
Any thoughts?
Type the letters in column A only, start each new sequence with the word HEADER. Then run the macro and the expansions should be created.
Sub expand()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim cell As Range, cellHeader As Range
Dim irow As Integer, i As Integer
Dim iCount As Integer, iLast As Long
' find last row in col A
iLast = ws.Range("A" & Rows.Count).End(xlUp).Row
'scan down the sheet
For Each cell In ws.Range("A1:A" & iLast)
If UCase(cell) = "DIRECT" Then
' remember the header line
Set cellHeader = cell
With cellHeader
.BorderAround xlContinuous
.Font.Bold = True
End With
ElseIf Len(cell) > 0 Then
cell.BorderAround xlContinuous
' start of sequence
If cell = "A" Then
irow = 1
iCount = 0
End If
' add header value
With cellHeader.Offset(0, irow)
.Value = "L" & irow
.Font.Bold = True
.BorderAround xlContinuous
End With
' copy cell diagonally upwards
If irow > 1 Then
For i = 1 To irow - 1
cell.Offset(-i, i) = cell.Value
cell.Offset(-i, i).BorderAround xlContinuous
Next
End If
' check max children
iCount = iCount + 1
If iCount > 10 Then
MsgBox "Children count > 10", vbCritical, "Error"
Exit Sub
End If
irow = irow + 1
End If
Next
MsgBox "Expansion Complete", vbInformation
End Sub
You do not answer my questions and I cannot wait, anymore...
Please test the next code, which works based on the thowe assumptions: Your hierarchies in discussion have all the time a kind of header (Direct in column A:A and L1 in B:B). This, or an empty row sets the bottom part of the hierarchy.
Here's the code:
Sub HierarchyArrangeMultipleR()
Dim sh As Worksheet, i As Long, j As Long, lastR As Long, lastH As Long
Dim arrI As Variant, arrTr As Variant, colN As Long, k As Long, h As Long
Set sh = ActiveSheet 'please, use here your worksheet
lastR = sh.Range("A" & sh.Rows.count).End(xlUp).Row
For k = 1 To lastR
If lastH > 0 Then k = lastH + 1
If k >= lastR Then Exit For
Start:
If sh.Range("A" & k).Value = "Direct" And sh.Range("B" & k).Value = "L1" Then
For i = 1 To 10
If sh.Range("A" & k + i).Value = "Direct" Or _
sh.Range("A" & k + i).Value = Empty Then
lastH = k + i - 1: Exit For
End If
Next i
For h = 3 To lastH - k
sh.Cells(k, h) = "L" & h - 1
Next h
Else
k = k + 1: GoTo Start
End If
arrI = sh.Range("A" & k + 1 & ":A" & lastH).Value
ReDim arrTr(1 To UBound(arrI) - 1)
colN = 1
For i = k To lastH - 2
For j = 1 To UBound(arrTr) 'lastH - i + k - 2
arrTr(j) = arrI(j, 1)
Next j
colN = colN + 1
sh.Range(sh.Cells(k + 1, colN), sh.Cells(lastH + 1 - colN, colN)).Value = WorksheetFunction.Transpose(arrTr)
Next i
Erase arrTr
Next k
End Sub

Count string within string using VBA

I have product codes: (they are in C column of active sheet)
DO-001
DO-002
DO-003
DO-004
And I have big list of data: (they are in C column of "Sheet1")
41300100_DO-001_14215171
41300104_DO-001_14215173
K1_ISK_41300661_DO-002_13190369
NP_41533258_DO-003_14910884
DO-003_DD_44_ddd
And I want to count how many times do the product codes appear in the list of data. So the result for this case'd be: (result is H column of active sheet)
DO-001 2
DO-002 1
DO-003 2
DO-004
I have done this with this code:
Sub CountcodesPLC()
Dim i, j As Integer, icount As Integer
Dim ldata, lcodes As Long
icount = 0
lcodes = Cells(Rows.Count, 3).End(xlUp).Row
ldata = Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row
For i = 10 To lcodes
For j = 2 To ldata
If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then
icount = icount + 1
End If
Next j
If icount <> 0 Then
Range("H" & i).Value = icount
End If
icount = 0
Next i
End Sub
But I want to change it, so if the list of data contains some key words like "NP", "ISK", then not to count them, or if the first part of the data is the code then also not to count them, so the result for this example would be:
DO-001 2
DO-002
DO-003
DO-004
Also, I'll have around 1.000 product codes, and around 60.000 strings of data.
Will my code crash?
Seems your code is OK. But if you want to match only the first part of string (a'ka StartsWith), i'd change only this line:
If InStr(Worksheets("Sheet1").Range("C" & j), Range("C" & i)) <> 0 Then
to:
If Worksheets("Sheet1").Range("C" & j) Like Range("C" & i) & "*" Then
For further details, please see: Wildcard Characters used in String Comparisons
Use Dictionnary
Dim Dict As Scripting.Dictionary
Set Dict = New Scripting.Dictionary
Arr = Split("refer your text here", "_")
For I = LBound(Arr) To UBound(Arr)
If Dict.Exists(Arr(I)) Then
Dict(Arr(I)) = Dict(Arr(I)) + 1 'increment
Else
Dict.Add Arr(I), 1
End If
Next I
This may be OTT for the requirement but should work quite quickly.
Public Sub Sample()
Dim WkSht As Worksheet
Dim LngRow As Long
Dim AryLookup() As String
Dim VntItem As Variant
'We put what we want to search into an array, this makes it a lot quicker to search
Set WkSht = ThisWorkbook.Worksheets("Sheet1")
ReDim AryLookup(0)
LngRow = 1
Do Until WkSht.Range("A" & LngRow) = ""
If AryLookup(UBound(AryLookup, 1)) <> "" Then ReDim Preserve AryLookup(UBound(AryLookup, 1) + 1)
AryLookup(UBound(AryLookup, 1)) = Trim(UCase(WkSht.Range("A" & LngRow)))
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
'Then we go down the list and check the array against each item
Set WkSht = ActiveSheet
LngRow = 1
Do Until WkSht.Range("A" & LngRow) = ""
WkSht.Range("B" & LngRow) = 0
For Each VntItem In AryLookup()
'This looks for the match without any of the exclusion items
If (InStr(1, VntItem, Trim(UCase(WkSht.Range("A" & LngRow)))) <> 0) And _
(InStr(1, VntItem, "NP") = 0) And _
(InStr(1, VntItem, "ISK") = 0) Then
WkSht.Range("B" & LngRow) = WkSht.Range("B" & LngRow) + 1
End If
Next
LngRow = LngRow + 1
Loop
Set WkSht = Nothing
MsgBox "Done"
End Sub
Basically, the 60,000 data strings will go into an array in memory, then the array will be searched against the 1,000 products. Searching in memory should be quick.
One thing I would raise is the exclusion method may produce false positives.
For example, excluding NP will exclude: -
NP_41533258_DO-003_14910884
NPA_41533258_DO-003_14910884
41533258_ANP_DO-003_14910884
You may want to think about the method overall.
Have you considered an array formula, not sure how it will perform vs code, but, you could do something along these lines, where list is in A and prod numbers in B
=SUM(IF(NOT(ISERR(SEARCH(B1 & "_",$A$1:$A$5,1)))*(ISERR(SEARCH("NP_",$A$1:$A$5,1))),1,0))
Where "NP" would be replaced by a range containing the exclusions, I've left as NP to show what's happening.
The code would be like this. But I don't know the speed.
Sub test()
Dim vDB, vLook, vSum(), Sum As Long
Dim Ws As Worksheet, dbWs As Worksheet
Dim s As String, sF As String, sCode As String
Dim i As Long, j As Long, n As Long
Set dbWs = Sheets("Sheet1")
Set Ws = ActiveSheet
With Ws
vLook = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With dbWs
vDB = .Range("c1", .Range("c" & Rows.Count).End(xlUp))
End With
n = UBound(vLook, 1)
ReDim vSum(1 To n, 1 To 1)
For i = 1 To n
sF = Split(vLook(i, 1), "-")(0)
sCode = Replace(vLook(i, 1), sF, "")
Sum = 0
For j = 1 To UBound(vDB, 1)
s = vDB(j, 1)
If Left(s, Len(sF)) = sF Or InStr(s, "NP") Or InStr(s, "ISK") Then
Else
If InStr(s, sCode) Then
Sum = Sum + 1
End If
End If
Next j
If Sum > 0 Then
vSum(i, 1) = Sum
End If
Next i
Ws.Range("h1").Resize(n) = vSum
End Sub

Resources