Insert New Row with Sequential Number after criteria is met - excel

I will admit to being a terrible at code, and have always struggled with Macros... forgive my ignorance.
What I am working on building is a part number index that will create a new sequential number within a numerical series after a macro-button is pressed.
I'd like each button to scan between a range [i.e. 11-0000 (MIN) and 11-9999 (MAX)] and select the max value cell that exists. At that selection point insert an entire new row below with the next + 1 sequential number in the "B" column.
I have my button creating the table row as I would like, however I need help in defining the ".select(=Max(B:B))" and as I understand Max will also limit the # of line items it queries?
I have also been playing with .Range("B" & Rows.CountLarge) with little to no success.
Ideally the 11-**** button [as seen in the screen cap] should insert a sequential number below the highlighted row.
Maybe I'm way over my head, but any guidance even in approach or fundamental structure of the code would help be greatly appreciated!
Private Sub CommandButton1_Click()
Sheets("ENGINEERING-PART NUMBERS").Range("B" & Rows.CountLarge).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Insert Shift:=xlDown
ActiveCell.Value = "=ActiveCell + 1"
End Sub
Screen Cap of Spread Sheet

Perhaps there is a simpler solution that I've overlooked, but the below will work.
Insert a module into your workbook and add this code:
Public Sub AddNextPartNumber(ByVal FirstCellInColumn As Range, Optional ByVal PartMask As Variant = "")
Dim Temp As Variant, x As Long, MaxValueFound(1 To 2) As Variant
'Some error checking
If PartMask = "" Then
MsgBox "No part mask supplied", vbCritical
Exit Sub
ElseIf Not PartMask Like "*[#]" Then
MsgBox "Invalid part mask supplied; must end in ""#"".", vbCritical
Exit Sub
ElseIf PartMask Like "*[#]*[!#]*[#]" Then
MsgBox "Invalid part mask supplied; ""#"" must be continuous only.", vbCritical
Exit Sub
End If
'Get the column of data into an array
With FirstCellInColumn.Parent
Temp = .Range(FirstCellInColumn, .Cells(.Rows.Count, FirstCellInColumn.Column).End(xlUp))
End With
'Search through the array and find the largest matching value
For x = 1 To UBound(Temp, 1)
If Temp(x, 1) Like PartMask Then
If MaxValueFound(1) < Temp(x, 1) Then
MaxValueFound(1) = Temp(x, 1)
MaxValueFound(2) = x
End If
End If
Next x
'Output new part number
If MaxValueFound(2) = 0 Then
'This part mask doesn't exist, enter one with 0's at the end of the list
With FirstCellInColumn.Offset(x - 1, 0)
.Value = Replace(PartMask, "#", 0)
.Select
End With
Else
'Get the length of the number to output
Dim NumberMask As String, NumFormatLength As Long
NumFormatLength = Len(PartMask) - Len(Replace(PartMask, "#", ""))
NumberMask = String(NumFormatLength, "#")
'Determine the new part number
MaxValueFound(1) = Replace(MaxValueFound(1), Replace(PartMask, NumberMask, ""), "")
MaxValueFound(1) = Replace(PartMask, NumberMask, "") & Format((MaxValueFound(1) * 1) + 1, String(NumFormatLength, "0"))
'Insert row, add new part number and select new cell
FirstCellInColumn.Offset(MaxValueFound(2), 0).EntireRow.Insert
With FirstCellInColumn.Offset(MaxValueFound(2), 0)
.Value = MaxValueFound(1)
.Select
End With
End If
End Sub
Then, for each button, you write the code like this:
Private Sub CommandButton1_Click()
'this is the code for the [ADD 11-****] button
AddNextPartNumber Me.Range("B16"), "11-####"
End Sub
Private Sub CommandButton2_Click()
'this is the code for the [ADD 22-****] button
AddNextPartNumber Me.Range("B16"), "22-####"
End Sub
This has been written assuming that inserting a new row onto your sheet won't affect other data and that adding new data to the bottom of the table without inserting a row also won't affect other data.
Assuming you're working with a table, by default it should auto-resize to include new data added to the last row.
Good luck learning the ropes. Hopefully my comments help you understand how what I wrote works.

Related

Barcode scanner automatic submit

I already have a barcode scanner VBA function, that recognizes the barcode number, but the problem I have is that I have to click enter every time, is there any way to do it automatically and store the count in a certain column? Currently it works if I enter the same value stored in column B, it will count the records in column C, but I want to avoid hitting enter every time
This is what I got so far
Private Sub btnAdd_Click()
Dim TargetCell As Range
If WorksheetFunction.CountIf(Sheets("Sheet1").Columns(2), TextBox1.Value) = 1 Then
Set TargetCell = Sheets("Sheet1").Columns(2).Find(TextBox1.Value, , xlValues, xlWhole).Offset(0, 1)
TargetCell.Value = TargetCell.Value + 1
Else
MsgBox "Code not found"
End If
Me.Hide
End Sub
It's hard to say what you have. For example, who presses the button? Or, does your scanner enter a return. I think the code below should work under any circumstances. Please try it.
Private Sub TextBox1_Change()
Dim TargetCell As Range
Dim Qty As Long
With TextBox1
If Len(.Value) = 3 Then
Set TargetCell = Worksheets("Sheet1").Columns(2) _
.Find(.Value, , xlValues, xlWhole)
If TargetCell Is Nothing Then
MsgBox """" & .Value & """ Code not found"
Else
With TargetCell.Offset(0, 1)
Qty = .Value + 1
.Value = Qty
End With
Application.EnableEvents = False
TextBox1.Value = "Count = " & Qty
Application.EnableEvents = True
End If
.SelStart = 0
.SelLength = Len(.Value)
End If
End With
End Sub
I think you have a user form and in this form you have a text box called TextBox1. If so, the code should be in the user form's code module. If you have a text box in your worksheet paste the code to the code module of the sheet on which the text box resides.
Now, you need to adjust this line of code If Len(.Value) = 3 Then to determine when to process the data. This is because the Change event will occur whenever even a single character is entered. I tested with 3 characters. Change the number to a value equal to the length of the numbers you scan in. In theory that still leaves the CR hanging which your scanner might also send. If that causes a problem experiment with >= in place of the = in my code.
The code will add the scan to the existing quantity, just as you had it, and indicate the new total in the text box, in case you are interested. You might replace this with "OK". The code will select the text it enters. Therefore when you enter something else, such as a new scan, it will be over-written without extra clicks being required.

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.

VBA: How to filter through a sheet based on a checkbox?

I'm new to VBA and I'm trying to set up a customizable sheet that allows the user to filter certain columns based on the checkboxes that I have set up. So far, I understand how checkboxes work and how I can integrate them into the code, but I think I have an issue with the autofilter function. Specifically, I think that I'm putting the wrong value for Criteria1.
I've been looking around for similar coding problems, but none of them seem to work with what I'm trying to do.
TL;DR I think my issue lies with how I format the array to put in Criteria1 of the AutoFilter()
Sub Auto_filter()
'variables are for checkboxes'
Dim VC1500 As Shape
Dim VC7500 As Shape
Dim VC144024 As Shape
'initiates to check for the checkboxes'
Set VC1500 = Sheets("Sheet7").Shapes("Check Box 4")
Set VC7500 = Sheets("Sheet7").Shapes("Check Box 5")
Set VC144024 = Sheets("Sheet7").Shapes("Check Box 6")
'if statement that will add a string to strCriteria if checkbox is true'
If VC1500.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", VC1500"
End If
If VC7500.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", VC7500"
End If
If VC144024.OLEFormat.Object.Value = 1 Then
strCriteria = strCriteria & ", 144024"
End If
'with statement that finds for column vendor then filter it based on
strCriteria, I think this is where my issue is'
With Worksheets("Open Purchase Orders")
With .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
Set vendorfind = .Rows(1).Find("Vendor")
If Not vendorfind Is Nothing Then
.AutoFilter Field:=vendorfind.Column,
Criteria1:=Split(strCriteria, ", "), Operator:=xlFilterValues
End If
End With
.AutoFilterMode = False
End With
End Sub
I expect to have the sheet filtered based on the checkboxes.
I get a runtime error 9 error:subscript out of range
Have you tried using Slices?
Its easy and should do simple filters without Macros.
Select your data > Insert Table.
Once the table is done, from the Design tab you can select "Insert Slicer".
Try if this solves your problem.
Some parts of that code look to me like scratching your left ear with your right hand going over your head. But I'm not entirely clear on how it actually looks (a sample would be helpful) - does each vendor have some separate indication column? If so, what are you filtering there? A vendor tag, by the looks of it?
This for example is a solution for a single vendor column (D) which may contain the 3 names. It basically applies an autofilter of a list of values. (I'm using activex checkboxes below as their properties can be accessed directly.)
Private Sub VC1500_Click()
Update_Filter
End Sub
Private Sub VC7500_Click()
Update_Filter
End Sub
Private Sub VC144024_Click()
Update_Filter
End Sub
Private Sub Update_Filter()
Dim varr_filter(3) As String
Dim indshow As Boolean
indshow = True
If VC1500 Then
varr_filter(0) = VC1500.Caption
indshow = False
End If
If VC7500 Then
varr_filter(1) = VC7500.Caption
indshow = False
End If
If VC144024 Then
varr_filter(2) = VC144024.Caption
indshow = False
End If
If indshow Then
Range("$A:$D").AutoFilter
Else
Range("$A:$D").AutoFilter field:=4, Criteria1:=varr_filter, Operator:=xlFilterValues
End If
End Sub
Note: Pick the correct column for filtering as the "field" value, and if you wish to separate the checkboxes from the form for some reason, then add """sheets("sheetname").{each checkbox}""".
Alternatively, if each of the vcs possesses a separate column, and seeking rows which literally say "vendor", I'd merge them in the sheet like so:
E2=if(cond1)*checkbox1 + if(cond2)*checkbox2 + if(cond3)*checkbox3 ; E > 0.
Cond1 could be b2="Vendor", for example.
To make the sheet display all cols when no ticks are selected,
I've added another value: 1 - max(checkboxes).
E6=1-MAX($H$4:$H$6) + IF(AND(B2="Vendor"),1,0)*$H$4 +
IF(AND(C2="Vendor"),1,0)*$H$5 + IF(AND(D2="Vendor"),1,0)*$H$6
That's one example where a hidden sheet value helps, since you can actually define such a column without vb. And then, the code itself is simplified a bit.
Private Sub VC1500_Click()
If VC1500.Value Then
Range("$H$4").Value = 1
Else
Range("$H$4").Value = 0
End If
Update_Filter
End Sub
Private Sub VC7500_Click()
If VC7500.Value Then
Range("$H$5").Value = 1
Else
Range("$H$5").Value = 0
End If
Update_Filter
End Sub
Private Sub VC144024_Click()
If VC144024.Value Then
Range("$H$6").Value = 1
Else
Range("$H$6").Value = 0
End If
Update_Filter
End Sub
Private Sub Update_Filter()
Range("$A:$E").AutoFilter field:=5, Criteria1:=">0", Operator:=xlFilterValues
End Sub
It's also easier to transition to a form control, by checking the range value during click instead of the checkbox, and hiding column H. Not entirely bulletproof yet sufficient for the average user. Either that or read the shape as you wrote.
Edit: Added tested code above for both cases (single col, multicol), including displaying all rows when no tickboxes are checked rather than none. Here are the demo shots.
Single col code
Single col sample sheet
Single col filtered
Multicol code
Multicol sample
Multicol filtered

Creating exact dates in Excel VBA by inputing only the day

In the following picture of an Excel sheet, the heading of the first column, and then of every 7th column after that, contains a month and a year.
I am trying to think of some code which would make entering complete dates under these headings faster. Since the month and the year are already present, I'm thinking there must be a way to enter just the day, and get the whole thing. For example, if "21" were entered in cell A26, "2/21/2015" would result.
Anyone have an idea for how I might get this output?
Edit: Thanks to the helpful replies on this forum, I figured out exactly how to do this. Here is the code for my finished product, in case anyone wants to do something similar:
Private Sub Worksheet_change(ByVal Selection As Range)
Set Sel = Selection
If Sel.Count > 1 Then
Exit Sub
End If
If (Sel.Column - 1) Mod 7 = 0 Or Sel.Column = 1 Then
'In my case, date columns always follow the pattern of 1, 8, 15...
If Sel.Value > 31 Or Sel.Value = "" Then
Exit Sub
Else
Sel.NumberFormat = "General"
Sel.Value = Left(Cells(1, Sel.Column), InStr(Cells(1, Sel.Column), ",") - 1) & " " & _
Sel.Value & Right(Cells(1, Sel.Column), 6)
Selection.NumberFormat = "m/d/yyyy"
End If
End If
End Sub
How about entering the day numbers, selecting the range where these day numbers are entered, and running the below:
Sub Add_month_year()
Dim c As Range
For Each c In Selection
c = Left(Cells(1, c.Column), InStr(Cells(1, c.Column), ",") - 1) & " " & _
c.Value & Right(Cells(1, c.Column), 6)
Next
End Sub
This should return the full dates in date code, which you can then format as you see fit.

excel vba split text

Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub

Resources