EXCEL VBA: For Loop involving checking Duplicates and continuing serial - excel

I am new at using VBA and I am trying to do something that seems "simple." I have my VBA code generate a string (CP20210100001) and I want my for loop to check if that string has already been used in that column. If already used, generate the next in the serial until the next unique value in the serial has been generated.
My boss wants to paste a different ID occasionally in the column and this disturbs the code. My code looks at the last row and adds one to the String + serial. This will result in duplicates.
I figured out through much googling to get the code to check the current value for duplicates but I can't figure out how to get it to check for future IDs in the series until it comes across a unique value.
Below you can see my column. I had 10 successful submission and then my boss pasted 3 rows. With my VBA the next generated ID would be CP20210200004 but last part of the code found it as duplicate so it added 1 and inputted CP20210200005. Ideally the VBA should for loop until the next in the serial shows up. In this case CP20210200011. This way no matter how many times my boss disrupts my table, my ID sequence stays in tact.
**Reference ID**
CP20210100000
CP20210200001
CP20210200002
CP20210200003
CP20210200004
CP20210200005
CP20210200006
CP20210200007
CP20210200008
CP20210200009
CP20210200010
JS20210200001
JS20210200002
JS20210200003
CP20210200005
Below is the the VBA
#Timestamp is part of the String + Serial Combo
Timestamp = Format(Year(Date)) + Format(Month(Date), "00")
#I found this online. Essentially if A2 is blank then input CP + Timestamp + 00001 (CP20210100001)
#It looks at the last row to find the old value (OVAL) and generate the new value (NVAL)
If Sheets(ws_output).Range("A2") = "" Then
Sheets(ws_output).Range("A2").Value = "CP" & Timestamp + 1
Else
lstrow = Sheets(ws_output).Cells(Rows.Count, "A").End(xlUp).Row
Oval = Sheets(ws_output).Range("A" & lstrow)
NVAL = "CP" & Timestamp & Format(Right(Oval, 4) + 1, "00000")
#Here I am trying to see if NVAL is a duplicate value. If so add one to the serial.
Count = Application.WorksheetFunction.Countif(Sheets(ws_output).Range("A2:A100000"), NVAL)
Dim Cell As Range
For Each Cell In Sheets(ws_output).Range("A2:A100000")
If Count > 1 Then
NXVAL = NVAL
Else
NXVAL = "CP" & Timestamp & Format(Right(NVAL, 4) + 1, "00000")
End If
Next
Please please please help.
EDIT
I Should clarify that all of this is triggered on a form. The module is connected to a submit button. Once the button is pressed all the values in the form write to a separate sheet. Reference ID is the only part that isn't on the form. Essentially once the button is pressed, it triggers the query to write the next available reference ID. The next line in the query is
Sheets("Sheet2").Cells(next_row, 1).Value = NXVAL
I need the new Reference ID to equal a variable.

Your code seems to give you much grief and little comfort. The reason is that you didn't take a strictly logical approach. The tasks are ...
Find the last used number. I suggest to use VBA's own Find function.
Insert the next number. It consists of prefix, Date and serial number.
So, you arrive at code like this:-
Sub STO_66112119()
' 168
Const NumClm As Long = 1 ' 1 = column A
Dim Prefix As String
Dim LastNumber As Long
Dim Fnd As Range ' search result
Prefix = "JS" ' you could get this from an InputBox to
' enable numbering for other prefixes
With Columns(NumClm)
On Error Resume Next ' if column A is blank
Set Fnd = .Find(What:=Prefix, _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
Lookat:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
LastNumber = Val(Right(Fnd.Value, 5))
On Error GoTo 0
Cells(Rows.Count, NumClm).End(xlUp).Offset(1).Value = Prefix & Format(Date, "yyyymm") _
& Format(LastNumber + 1, "00000")
End Sub
You need to spend a moment on preparation, however.
Define the column to work in. I put this in the Const NumClm. It's at the top of the code so as to make maintenance easier (won't need to dig in the code to make a change).
My code shows Prefix = "JS". You want to change this to "CP". I inserted "JS" to show that you could use any prefix.
The above code will continue counting up in a new month and even a new year. If you want to start each year with a new series just change the way you handle the found previous. The Find function will return the cell where the prefix was last used. You might further examine that cell's value.

Related

Assign multiple named ranges to multiple range arrays

I'm kinda new here, but here is what I'm trying to do.
I have a book lets pretend its a warehouse book for inventory, and we have different divisions in our enterprise, I have master sheet with all the goods and some sheets covering those divisions for distribution of goods between them.
My idea is to have a drop down list for each item type in book for separate divisions so i need macro to assign/reassign named range for each item.
I have 2 columns first with stock number and second with serial number , i need to put all the same serial number in the named range of one of stock numbers. if i have two or more serial numbers i need to put an array of serial numbers in named range of one stock number.
Stock numbers are in C column and serial numbers are in D column
I've tried this code
Private Sub CommandButton2_Click()
Dim LastRow As Long
Dim r As Range
LastRow = Cells(Rows.Count, "C").End(xlUp).Row
For Each r In Range("C2:C" & LastRow)
Range(r.Offset(0, 1), r.Offset(0, 1)).Name = r.Value
Next r
End Sub
But thats not realy working, and assigns only one serial number per one named range of stock numbers
================================================================
So i ran this code you proposed in your updated version and struck some problems
Private Sub CommandButton2_Click()
Dim this As Worksheet: Set this = Sheets("ALFA")'renamed this for my book'
Dim that As Worksheet: Set that = Sheets("STORAGE")'renamed that for my book'
serialNumbers = that.Range(that.Columns(3), that.Columns(4))'Could not find method Unique(and there is no mentions about'
'it in MS documentation) for Application object so i changed it to just Range'
For r = 2 To this.UsedRange.Rows.Count
buffer = ""
comma = ""
stockNumber = this.Cells(r, 3)
For x = 2 To UBound(serialNumbers)
If serialNumbers(x, 1) = stockNumber Then
buffer = buffer & comma & serialNumbers(x, 2)
comma = ","
End If
Next
this.Cells(r, 4).Validation.Delete
this.Cells(r, 4).Validation.Add _'After doing everything it strucks with Run time error 1004
Type:=xlValidateList, _ '/Application-defined or object-defined error in this
AlertStyle:=xlValidAlertStop, _'hole'
Formula1:=buffer 'block'
Next
End Sub
And sometimes code just hangs my excel application for atleast 3 mins, i think it's because there is no limit for cells to look up to and eventualy it tries to give all the cells in D:D a validation check
So if you want to set the validation, it is possible to set dynamic ranges BUT the validation won't accept a text list, for instance "one, two, three". The validation is looking for an array of values, and unfortunately it is tricky to pass a dynamic array using formulas only. You can set it up to do a dynamic range, but that would have to point to a range of cells that contain the needed values one per cell.
However, before you set all that up it's probably just easier to set the validation entirely in code. See this google sheet, which just contains the layout for reference. I have the complete list of items in Column 1 & 2 of the sheet (Item, Stock Number) and the complete list of serial numbers in columns 5 & 6 (Stock Number, Serial Number).
Then I run this code:
Sub setValidation()
Dim this As Worksheet: Set this = Sheets("demo")
Dim that As Worksheet: Set that = Sheets("lookups")
serialNumbers = Application.Unique(that.Range(that.Columns(5), that.Columns(6)))
For r = 2 To this.UsedRange.Rows.Count
buffer = ""
comma = ""
stockNumber = this.Cells(r, 3)
For x = 2 To UBound(serialNumbers)
If serialNumbers(x, 1) = stockNumber Then
buffer = buffer & comma & serialNumbers(x, 2)
comma = ","
End If
Next
this.Cells(r, 4).Validation.Delete
this.Cells(r, 4).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:=buffer
Next
End Sub
We assign some worksheet variables to make it easier to reference them, and then put the stock number/serial number combos into an array (with UNIQUE so I don't have to check for duplicates).
Then I run through the range that needs the validations (demo column 4), getting the stock number from column 3 and then using that stock number to find all serial numbers that match, concatenating them into a string and then using that string to set the validation.
Use Validation.Delete before setting the validation to avoid stacking rules.
Assuming that your version of Excel doesn't have UNIQUE, you can use INTERSECT to control the size of the serialNumbers array, like this:
Sub setValidation()
Dim this As Worksheet: Set this = Sheets("demo")
Dim that As Worksheet: Set that = Sheets("lookups")
serialNumbers = Intersect( _
that.Range(that.Columns(5), that.Columns(6)), _
that.UsedRange _
)
For r = 2 To this.UsedRange.Rows.Count
buffer = ""
comma = ""
stockNumber = this.Cells(r, 3)
For x = 2 To UBound(serialNumbers)
If serialNumbers(x, 1) = stockNumber Then
buffer = buffer & comma & serialNumbers(x, 2)
comma = ","
End If
Next
this.Cells(r, 4).Validation.Delete
this.Cells(r, 4).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:=buffer
Next
End Sub
Assuming you do have UNIQUE and FILTER in your Excel version, there is another way to do it, using the EVALUATE function to access the Excel function engine. In this case we will just write out a formula just like we would in a cell, and then evaluate it from VBA. Unless specified, evaluate occurs in the context of the active sheet, so that's what I use that.evaluate in this code:
Sub setValidation()
Dim expr As String
Dim this As Worksheet: Set this = Sheets("demo")
Dim that As Worksheet: Set that = Sheets("lookups")
For r = 2 To this.UsedRange.Rows.Count
stockNumber = this.Cells(r, 3)
expr = "Textjoin("","", true, Unique(Filter(F:F, E:E=""" & stockNumber & """)))"
serialNumbers = that.Evaluate(expr)
this.Cells(r, 4).Validation.Delete
this.Cells(r, 4).Validation.Add _
Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:=serialNumbers
Next
End Sub
In this case, we use FILTER to return ONLY the serial numbers that match a stock number, UNIQUE to make sure there are no duplicates, and then TEXTJOIN to create a list from that, and then we can just pass that result straight to the validation.
===================================================
Original answer, shows how to get a list of all serial numbers for a specific stock number using only excel formulas, but it became clear that this wouldn't be sufficient, since the lists were going to be used to set validation. Left here for completeness.
So you have two columns, C and D, and you need to get a list of all values in D that match the entries in C. This is actually simple enough to not need code, but you may have more requirements. I'm going to start an answer with just a very basic set of formulas. See this google sheet.
To get a unique list of the stock numbers, I have used UNIQUE(C:C) in G1. This will produce the list in column G.
Then in column H, I have used TEXTJOIN+UNIQUE+FILTER to produce a comma separated list of serial numbers. FILTER takes one input array (in this case Col D) and filters it with another array (Col C) and a condition (the serial number) to return a list of matches, and wrapping that in UNIQUE makes sure that the result array contains only unique values. Wrapping that in TEXTJOIN converts the result array into text.
What I'm not entirely clear on is your need for a named range, or what you will do with the multiple rows in a sheet. For instance, STORAGE rows 35 & 36 are both for DDG_33:
DDG_33 0BV1111
DDG_33 0AV0951
and if you ran some code to produce a list of values and put it in D35 you would have:
DDG_33 0BV1111, 0AV0951
DDG_33 0AV0951
but you would still have two entries for DDG_33. If you ran the code again, you would have
DDG_33 0BV1111, 0AV0951, 0AV0951
DDG_33 0AV0951
and so forth in an infinite loop. It seems like you would need to take the list of unique stock numbers and put them on a different sheet, along with the list of matching serial numbers, but just clarify what you want to do and I can update my answer.

Turn a function into a subprocess -- STUCK

Column 'P' ("P6:P3000") holds a value as such "EMPLOYEE_CONTRACT_STATUS_Closed". I am trying to pull the "Closed" (could also be "Open") portion out of the cell into column 'Q' or just replace the existing column 'P' value with the last text after the delimiter ("_")... "EMPLOYEE_CONTRACT_STATUS_Closed" --> "Closed" or "Open." This creates these steps:
Create new column Q
Insert new value in column header
Perform function in 'P' to either replace values or dump into column 'Q' ("Q6:Q3000")
Below I have what I have so far --> Code to create column and to call a function code to pull the last text after last delimiter... this is a part of an automated process so the goal is not to touch or manipulate any of the
cell values. I know there is possibly for a Subprocess to perform this but I cannot figure it out and keep scratching my head. This is my first time on the forum and for someone to supply a fixed code but also EXPLAIN the syntax behind it would be great because I am pretty experience with VBA, but have never ran into this process. THANKS ^_^
& 2. Creating new column and changing the header name:
Sub ContractStatus_Change()
Application.ScreenUpdating = False
Workbooks("DIV_EIB_Tool.xlsm").Worksheets("EIBMaintainEmployeeContractsW31").Range("Q5") _
.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Worksheets("EIBMaintainEmployeeContractsW31").Range("Q5").Value = "Contract Status"
Worksheets("EIBMaintainEmployeeContractsW31").Range("Q6:Q3000").NumberFormat = "General"
Application.ScreenUpdating = True
End Sub
My function to pull last text out from disclosed value:
Function RightWord(r As Range) As Variant
Dim s As String
s = Trim(r.Value)
RightWord = Mid(s, InStrRev(s, "_") + 1)
End Function
I have not run into an error yet, just do not know how to piece this together, under assumption I can probably run this all through one sub process but I am having a massive brain fart.
Try this code
Sub Test()
Dim a, i&
With Worksheets("EIBMaintainEmployeeContractsW31")
.Columns("Q").Insert
a = .Range("P6:P" & .Cells(Rows.Count, "P").End(xlUp).Row).Resize(, 2).Value
For i = LBound(a) To UBound(a)
If InStr(a(i, 1), "_") Then
a(i, 2) = Split(a(i, 1), "_")(UBound(Split(a(i, 1), "_")))
End If
Next i
With .Range("Q5")
.Value = "Contract Status"
.Offset(1, -1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End With
End With
End Sub
I started the code by dealing with the sheet EIBMaintainEmployeeContractsW31 so between With and End With you will notice some lines start with dot which refers to this worksheet. Then insert a column before column Q and stored the required range which is P6 to P & last row into an array (arrays are faster)
After that looping the array which holds two columns (one for the raw data and the other for the required output). Make sure of underscore existence using InSstr function then if it exists store into the second column the last part of the split output based on the underscore.
Finally populating the array into the worksheet.
Hope that explanation helps you.

Creating a custom string sort list for bubble sort

I get the gist of bubble sort but I'm struggling of finding a way to implement "string 1" > "String 2". I'll start off by describing my workbook.
My workbook is a shared excel file used to track everyone's day-to-day project progress. Every day at noon the workbook will add a new column with the days date into column G. Because of this there is no definite right end to the workbook due to it adding one column every day. Rows 1 through 11 are frozen and are filled with non project specific info (e.g. legend, a message board, buttons for other macros, column headers)
Each project in the workbook takes up three rows (ex. rows 12-14 is the first project listed, rows 15-17 is the second project listed). Column A has the rows "Status", "Start Date", and "End Date". My aim is to sort the projects by status. The status cell has a drop-down list with six different options: "R" fur running", "S" for setup", "H" for hold, "P" for report, "U" for upcoming, and "C" for complete. This is also the order I hope to sort the projects by.
I found I version of bubble sort I'm planning to implement here. The sub from this post is:
'============================================================================
'- BUBBLE SORT EXAMPLE : 3 NUMBERS (ASCENDING)
'- The method is to use a "pointer" and check its current position in the array.
'- If the current number is more than the next then switch their positions in the array.
'- If a position is changed then set a marker so the pointer goes through again.
'- The sort is complete when the pointer has gone through the array without change.
'- Brian Baulsom October 2008
'=============================================================================
Sub SORT_()
Dim MyNumbers(3)
Dim Pointer As Integer
Dim Changed As Boolean
Dim MyTemp
'-------------------------------------------------------------------------
MyNumbers(1) = 30
MyNumbers(2) = 20
MyNumbers(3) = 10
'-------------------------------------------------------------------------
Do
Changed = False
For Pointer = 1 To 3 - 1
If MyNumbers(Pointer) > MyNumbers(Pointer + 1) Then
MyTemp = MyNumbers(Pointer)
MyNumbers(Pointer) = MyNumbers(Pointer + 1)
MyNumbers(Pointer + 1) = MyTemp
Changed = True
End If
Next
Loop While Changed = True
'-------------------------------------------------------------------------
MsgBox (MyNumbers(1) & vbCr & MyNumbers(2) & vbCr & MyNumbers(3) & vbCr)
End Sub
'============================================================================
With this I plan on changing how it changes the sorted number to instead cut and paste.
I know I can't just put If "P" > "C" without it throwing errors. So where I'm at now is figuring out how to give each of the strings values I can sort by while still (preferably) only having one IF loop.
Do the numbers saved as MyNumbers(1), MyNumbers(2) sort by the number index or the .Value? If it sorts by index then there shouldn't be a problem with creating:
MyNumbers(1) = "R"
MyNumbers(2) = "S"
MyNumbers(3) = "H"
MyNumbers(4) = "P"
MyNumbers(5) = "U"
MyNumbers(6) = "C"
but I'm still unfamiliar enough with VBA to figure this out easily.

For Loop deletes all rows

I have never coded in VBA before and am trying to teach myself based off Youtube videos right now which is proving difficult. I am attempting to do a for loop that deletes a row if it does not equal the Part Number, and if the part number is correct, I want the loop to do nothing and move on. I have been typing up random lists of numbers to test my code on, but when I run it, every single row is deleted (even the ones with the correct part number). Ultimately, when I run this on the real data the part number will be a combination of letters and numbers as well as a dash, so I should be storing the Part Number as a string variable correct? Any advice?
Sub CodingPrac()
Dim PartNum As String
PartNum = InputBox("Enter the Part Number", "Part Number", "Type value here")
lastrow = ThisWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If Cells(i, 1).Value = "PartNum" Then
Else
ThisWorkbook.Sheets(2).Rows(i).EntireRow.Delete
End If
Next i
End Sub
Replace:
If Cells(i, 1).Value = "PartNum" Then
with:
If Cells(i, 1).Value = PartNum Then
you need the value of the variable, not a string.
EDIT#1:
Your code (as posted) would work if column A was like:

VBA - Loop will not increment by one each time in ID column

In my VBA code, I am attempting to do the following:
Set the Active Cell to C11
Add the number 1 to an id
Prompt the user for a name and enter that in the cell to the right
Go to the next row & repeat.
However, the number that is entered is another one, not a 2, 3, 4....
Instead, I get the following:
1 Name 1
1 Name 2
1 Name 3
and I want:
1 Name 1
2 Name 2
3 Name 3
Here is the code, what am I missing?
Sub AddToSheet()
Dim id As Integer
Dim name As String
Worksheets("sheet1").Activate
ActiveCell.Range("C11").Select
For Each mycell In Range("C11:C20")
id = mycell.Select
ActiveCell.Value = 1
id = id + 1
name = mycell.Offset(0, 1).Select
name = InputBox("what is the film?")
ActiveCell.Value = name
Next mycell
End Sub
It's not what you're missing, it's what you are getting wrong - some pointers:
1) There is rarely (dare I say, never) a need to use .Select in Excel VBA, you can access an object's properties directly without selecting the actual object. This is generally considered bad practice.
2) id = mycell.Select is not a valid statement, the .Select method merely sets focus to an object(s) it is not used to return a value.
3) ActiveCell.Value = 1 <-- This is where you are going wrong as far as your question is concerned
4) Your code increments the value of id with each loop, but you do not actually use this value for anything - another hint at why it's not working as you expected.
5) Try and use indentation on your code, this will make it much easier for you (and others) to follow the logic of your code and help to ensure you have closed all 'block' statements.
Try this code instead:
Sub AddToSheet()
Dim i As Integer
For i = 11 To 20
Range("C" & i & ":D" & i).Value = Array(i - 10, InputBox("What is the film?"))
Next i
End Sub
This accesses the .Value method of the Range object without actually selecting or activating it, and so we skip a couple of lines of code straight away. Secondly - I've used an Array to assign the values so that we can do it all in one line of code - this is nothing groundbreaking and you won't see any difference in speed/performance but it's hopefully something for you to look at and possibly manipulate for your own uses in the future.

Resources