Related
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
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
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 am trying to use a loop with vba to sum values from one worksheet to another. I am struggling with writing my code to match values from Sheet 4 and if the value matches then sum the categories from Sheet 1, if not then skip to the next office. I would also like to exclude certain categories from being included in the SUM loop for example, exclude "Book". Currently my macro is writing to Sheet3. Here is my code:
Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
Next
ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
a(1, 1) = Sheets("sheet1").[a1]
For i = 0 To dic.Count - 1
a(1, i + 2) = dic.Keys()(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .Keys()(i)
For ii = 2 To UBound(a, 2)
a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
Next
Next
End With
With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.EntireColumn.ClearContents
Sheets("sheet1").[a1].Copy .Rows(1)
.Value = a: .Columns.AutoFit: .Parent.Activate
End With
End Sub
This is how the data looks
and this is the output that is desired
In this example, we will use arrays to achieve what you want. I have commented the code so that you shall not have a problem understanding it. However if you still do then simply ask :)
Input
Output
Logic
Find last row and last column of input sheet
Store in an array
Get unique names from Column A and Row 1
Define output array
Compare array to store sum
Create new sheet and output to that sheet
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim tempArray As Variant, OutputAr() As Variant
Dim officeCol As New Collection
Dim productCol As New Collection
Dim itm As Variant
Dim lrow As Long, lcol As Long, totalsum As Long
Dim i As Long, j As Long, k As Long
'~~> Input sheet
Set ws = Sheet1
With ws
'~~> Get Last Row and last column
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Store it in a temp array
tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
'~~> Create a unique collection using On error resume next
On Error Resume Next
For i = LBound(tempArray) To UBound(tempArray)
officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
Next i
On Error GoTo 0
End With
'~~> Define you new array which will hold the desired output
ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)
'~~> Store the rows and columns in the array
i = 2
For Each itm In officeCol
OutputAr(i, 1) = itm
i = i + 1
Next itm
i = 2
For Each itm In productCol
OutputAr(1, i) = itm
i = i + 1
Next itm
'~~> Calculate sum by comparing the arrays
For i = 2 To officeCol.Count + 1
For j = 2 To productCol.Count + 1
totalsum = 0
For k = LBound(tempArray) To UBound(tempArray)
If OutputAr(i, 1) = tempArray(k, 1) And _
OutputAr(1, j) = tempArray(k, 2) Then
totalsum = totalsum + tempArray(k, 3)
End If
Next k
OutputAr(i, j) = totalsum
Next j
Next i
'~~> Create a new sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Outout the array
wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub
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