Adding recursive loop/function into a sort in VBA - excel

I have a bubble sort that only works with the first element.
This is solved by reevaluating my array elements and placing them accordingly, which happens if I run the whole thing time and time again.
I'd like to add a recursive loop that's set to break when the sort is done.
I tried adding a function, but I'm not solid enough on my syntax to combine it with my sub. What is a basic recursion loop for this code? Function not expressly required, just something that will let me recall my sub.
Private Sub SortEverything_Click()
Dim everything() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
Dim everyrow As Long
Dim everycol As Long
Dim firstrow As Long
Dim firstcol As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "everything" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim everything(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set everything(y) = check
y = y + 1
check.Select
Next x
'This For has been commented out so that it doesn't run more than once
'For y = 0 To q - 1
'sorting allows us to copy/paste into a helper range line-by-line as the program loops
'firstman is the helper range. firstrow and firstcol return the dimensions of the everything(y) so that we can resize things
Set sorting = everything(0)
Set firstman = .Range("B20")
Set firstman = firstman.Resize(sorting.Rows.count, sorting.Columns.count)
firstman.Value = sorting.Value
firstrow = firstman.Rows.count
firstcol = firstman.Columns.count
'Returns the name of the RM listed to compare to the one below it
sorting.Offset(0, 1).Select
ActiveCell.Select
Temp1 = "" & ActiveCell.Value
For x = 1 To q - 1
'Checks whether a selected component has subcomponents and identifies its dimensions
sorting.Select
Set holder = everything(x)
holder.Offset(0, 1).Select
everyrow = Selection.Rows.count
everycol = Selection.Columns.count
'Returns the name of the material being compared to the referenced material in everything(y)
ActiveCell.Select
Temp2 = "" & ActiveCell.Value
If Temp2 > Temp1 Then 'If the RM we're on comes alphabetically after the name of the one we're checking against, then
If everyrow > 1 Then 'Handles if everything(x) has subcomponents
'Resize the other helper range to be the same as the range with subcomponents and paste the values into it
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(everyrow, everycol)
middleman.Select
middleman.Value = holder.Value
'Resize the range we're pasting into in the master table so it can take the new range, then paste
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
'Resize the holder column to the same size as everything(y).
'Then paste everything(y) into the space BELOW the one we've just shifted upwards
Set holder = holder.Resize(firstrow, firstcol)
Set holder = holder.Offset(everyrow - 1, 0)
holder.Select
holder.Value = firstman.Value
Set sorting = sorting.Offset(everyrow, 0)
Else
Set middleman = .Range("A1").Offset(0, everything(x).Columns.count)
Set middleman = middleman.Resize(firstrow, firstcol)
middleman.Select
middleman.Value = holder.Value
Set sorting = sorting.Resize(everyrow, everycol)
sorting.Select
sorting.Value = holder.Value
Set holder = holder.Resize(firstrow, firstcol)
'Set firstman = firstman.Resize(everyrow, everycol)
holder.Select
holder = firstman.Value
Set sorting = sorting.Offset(1, 0)
End If
End If
Next x
'Next y
'This is where my inexperience shows. The recursion should go here, but I'm not sure how to do so.
'PopulateArray (everything)
End With
End Sub
Public Function PopulateArray(myArray()) As Variant
Dim myArray() As Range
Dim check As Range
Dim count As Range
Dim sorting As Range
Dim holder As Range
Dim middleman As Range
Dim firstman As Range
Dim Temp1 As String
Dim Temp2 As String
Dim lr As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim q As Long
y = 0
z = 0
q = 0
With ThisWorkbook.Sheets("Names and Vendors")
lr = .Cells(.Rows.count, "B").End(xlUp).Row
'Counts number of RMs to size the "myArray" array
For z = 2 To lr
Set count = .Range("B" & z)
If IsEmpty(count) = False Then
count.Select
q = q + 1
End If
Next z
ReDim myArray(q - 1) As Range 'Resizes array
'Loops all RM info into array by each distinct range
For x = 2 To lr
Set check = .Range("A" & x & ":H" & x)
'ensures subcomponents are added to range
If IsEmpty(.Range("B" & 1 + x)) = True Then
Do While IsEmpty(.Range("B" & 1 + x)) = True And x < lr
Set check = Union(check, .Range("A" & 1 + x & ":H" & 1 + x))
check.Select
x = x + 1
Loop
End If
Set myArray(y) = check
y = y + 1
check.Select
Next x
End With
End Function

Found out what I needed to do. Put the whole thing under a Do loop and then added the following lines to it:
'checking to see if array is completely alphabetized
For Each cell In .Range("B2:B" & lr)
'Returns first check value
If IsEmpty(cell) = False Then
cell.Select
check1 = "" & cell.Value
x = cell.Row
.Range("A14").Value = check1
'Returns next check value
For z = x + 1 To lr
Set checking = .Range("B" & z)
If IsEmpty(checking) = False Then
checking.Select
check2 = "" & .Range("B" & z).Value
.Range("A15").Value = check2
Exit For
End If
Next z
Else
End If
If check2 > check1 Then
Exit For
End If
Next cell
'If the last two values are sorted, then the whole thing is sorted and we can stop the recursion
If check2 < check1 Or check1 = check2 Then
Exit Do
End If

Related

Copy-Paste above row's Range if a specific range is empty and another is not

I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False

How can I increment column value in excel VBA?

I have 2 excel sheets one is mapping and other is soneri. I want to increment the values of Column D in soneri sheet which was get by lookup function. What is the mistake in my code?
soneri sheet
mappingsheet
Outcome
Column D
Only first 2 rows are correct of my outcome else are wrong.
Expected Outcome
Below is my code
"WORKING CODE EDITED"
Sub ButtonClick()
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, i As Long
Dim datarange As Range, assetrange As Range, b As Range
Dim entry As Variant
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
i = 0
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
If entry = entry.Offset(-1) Then
i = i + 1
b = Left(b, Len(b) - 1) & (Right(b, 1) + i)
Else
i = 0
End If
Next entry
End Sub
Rows.Count returns that number of rows for the active sheet. Try changing these two lines:
sonerilastrow = soneriWs.Range("I" & Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & Rows.Count).End(xlUp).Row
To this:
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Also remember to clear any errors that might occur, otherwise you can run into trouble. Insert this before the Sub returns:
If Err <> 0 Then Err.Clear
I see you removed your "on error" statement.
I would also recommend that you force variable decalarations, as I can see you use undeclared variables, which will also get you into trouble sooner or later. Insert this as the first line in all modules:
Option Explicit
EDIT:
Please post test data "as text" next time to help people help you.
Here is a solution.
I uncommented your if statement, as it seem to not update the first record.
Sub ButtonClick()
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, x As Long, b As String, c As String
Dim Dct As Object
Dim Cnt As Long
Dim CntTxt As String
Dim PreTxt As String
Dim Idx As Long
Dim datarange As Range
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.UsedRange.Rows.Count
mappinglastrow = mappingWs.UsedRange.Rows.Count
Set Dct = CreateObject("Scripting.Dictionary")
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
For x = 2 To sonerilastrow
b = Application.WorksheetFunction.VLookup(soneriWs.Range("I" & x).Value, datarange, 2, False)
Idx = InStr(b, "-")
PreTxt = Left(b, Idx)
CntTxt = Mid(b, Idx + 1)
If Dct.Exists(b) Then
Cnt = Dct(b) + 1
Else
Cnt = Val(CntTxt)
End If
Dct(b) = Cnt
'If x > 2 Then
c = PreTxt & Format(Cnt, "0000")
' Use this instead, if you want to preserve the number of characters
'c = PreTxt & Format(Cnt, String(Len(CntTxt), "0"))
soneriWs.Range("D" & x).Value = c
'End If
Next x
End Sub
If you are new to VBA I recommend that you learn how to use the Scripting.Dictionary.
Your loop is only made for a single match of the Asset class.
There are a few problems here, but the if x > 2 approach would really only work if there was only one counter. Then we could substitute + 1 with something like + x - 2 (since we start at 3 for this part of the code).
But what you need is a counter that resets each time there is a new Asset class.
n = 1
For x = 2 To sonerilastrow
b = Application.WorksheetFunction.VLookup( _
soneriWs.Range("I" & x).Value, datarange, 2, False)
soneriWs.Range("D" & x).Value = b
If x > 2 Then
If Not Left(b, 7) = Left(soneriWs.Range("D" & x -1).Value, 7) then
n = 1
else
c = Left(b, 7) & Format(Val(Right(b, 4)) + n, "-0000")
soneriWs.Range("D" & x).Value = c
n = n + 1
End if
End If
Next x
Another way of writing it would be
Dim soneriWs As Worksheet, mappingWs As Worksheet
Dim sonerilastrow As Long, mappinglastrow As Long, i As Long
Dim datarange As Range, assetrange As Range, b As Range
Dim entry As Variant
Set soneriWs = ThisWorkbook.Worksheets("Soneri")
Set mappingWs = ThisWorkbook.Worksheets("Mapping")
sonerilastrow = soneriWs.Range("I" & soneriWs.Rows.Count).End(xlUp).Row
mappinglastrow = mappingWs.Range("A" & mappingWs.Rows.Count).End(xlUp).Row
Set datarange = mappingWs.Range("A2:B" & mappinglastrow)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
i = 0
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
If entry = entry.Offset(-1) Then
i = i + 1
b = Left(b, Len(b) - 1) & (Right(b, 1) + i)
Else
i = 0
End If
Next entry
But it's using much the same approach.
These however expect the data to be sorted on the "I" column, since the counter will reset if there is another asset in between.
If you want it to work even when not sorted, you could use something like countIf, like so: (Replacing the loop)
Set assetrange = soneriWs.Range("I2:I" & sonerilastrow)
assetrange.Offset(, -5).Clear
For Each entry In assetrange
Set b = entry.Offset(, -5)
b = Application.WorksheetFunction.VLookup(entry, datarange, 2, False)
i = Application.WorksheetFunction.CountIf(assetrange.Offset(, -5), Left(b, 5) & "*")
b = Left(b, Len(b) - 1) & (Right(b, 1) + i - 1)
Next entry

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

My Paste function isn't working and I don't know why

I am trying to copy the entry forms I select from the master list to a different worksheet. The idea is that it goes down a condensed list of names without details. Looks at what I have selected. Copies the selected entry form and pastes it in a new place to generate a list that only contains the entry forms I need. I can't tell if the loop is working properly because the paste function at the end isn't working.
Sub BidList()
'Sets unique terms used throught this code
Dim wQuick As Worksheet, wMaster As Worksheet
Dim BlankFound As Boolean
Dim x As Long, n As Long, y As Long
Dim firstrow As Long, pasterow As Long, lastrow As Long, PasteCell As String, MyRange As String
'Turns off Screen updating to save memory
Application.ScreenUpdating = False
'Store an initial value for "x" effectively starting the macro at C4 after the +1 in the next step
x = 3
n = 0
y = 0
Set wQuick = ThisWorkbook.Sheets("Quick Reference")
Set wMaster = ThisWorkbook.Sheets("MASTER")
BlankFound = False
'Loop until x equals 600
Do While BlankFound = False
x = x + 1
n = n + 1
If Trim(wQuick.Cells(x, "B").Value) = "" Then Exit Do
'If there is a 1 in the Boolean column then ...
If Trim(wQuick.Cells(x, "C").Value) = "1" Then
'Move the y value so that the template is pasted in the appropriate place
y = y + 1
'Copy the appropriate form from wMaster
firstrow = (n * 9) + 18
lastrow = (n * 9) + 27
Let MyRange = "A" & firstrow & ":" & "K" & lastrow
wMaster.Range(MyRange).Copy
'Select the next place for the form to be pasted on wQuick
pasterow = (y * 9) - 5
Let PasteCell = "F" & "," & pasterow
wQuick.Cells(PasteCell).Paste
End If
Loop
Application.ScreenUpdating = True
End Sub
Please avoid copy-paste in Excel, better use a for-loop like the following:
# keep track of MyRange.Row and MyRange.Column
For Each cell in wMaster.Range(MyRange):
wQuick.Cells(<Starting point>).Offset(<take the cell coordinates, based on MyRange.Row and/or MyRange.Column>).Value = cell.Value
Next

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