VBA - Finding the Next row and Auto-incrementing the Log ID - vba

Assistance required on this one, its probably something easy but im still developing when it comes to VBA.
I have a userform that is used to update a log of requests, i want it to operate so that it looks down column A to establish the Last row and the Last used reference number. Once the new submission is entered i want it to populate to the next blank row whilst auto incrementing the reference number. The reference Numbers are formatted as below.
Column A (RefNo)
Column B LA
LSI-1
Data
LSI-2
Data
LSI-3
Data
LSI-4
Data
etc..
Data
just for reference, due to the logs headers etc, LSI-1 starts on row 6.
Private Sub UserForm_Initialize()
Me.Height = 424
Me.Width = 438
Me.Zoom = 100
Txt_DateLogged.Value = Format(Date, "dd/mm/yyyy")
Txt_Month.Value = Format(Date, "MMM-YY")
Call CBO_Supplier_Items
Call CBO_SRM_Items
Call CBO_Cause_Items
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("LSI Log")
With ws
i = .Rows.Count
lstdt = .Range("A" & i).End(xlUp).Value
Me.Txt_IssueNum.Value = "LSI-" & lstdt + 1
End With
End Sub
On the userform there is a textbox Txt_IssueNum which is not enabled but i want it to be populated with the new reference number during the userform Initialising.
When i run my code above i get the Error Type Mismatch error message.
Any thoughts where im going wrong with it?
Thanks in advance.

Threw this together so might not be the best code for finding the max (end of the day).....
With your data as below (not sorted, different text in there)
Option Explicit
Public Sub Test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
'Set reference to your data range.
Dim TheData As Range
With ws
Set TheData = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Ask for the next ID relevant to LSI- type.
MsgBox GetNextID(TheData, "LSI-")
End Sub
Public Function GetNextID(MyDataRange As Range, StartText As String) As String
Dim IDCollection As Collection
Set IDCollection = New Collection
'Put all numbers relevant to the correct type into a collection.
Dim itm As Variant
For Each itm In MyDataRange
If Left(itm, Len(StartText)) = StartText Then
'Remove the StartText, turn the number into a value.
IDCollection.Add Val(Replace(itm, StartText, ""))
End If
Next itm
'Find the maximum number.
Dim MaxNum As Long
For Each itm In IDCollection
If itm > MaxNum Then MaxNum = itm
Next itm
'Add the StartText back and return the result.
GetNextID = StartText & MaxNum + 1
End Function
Results when looking for "LSI-" and then "AB-":

Extract Trailing Integers
A Test
Use this test sub before using the function in your sub.
Sub Test()
Debug.Print GetNewId
End Sub
The Function
Adjust the first cell "A2".
Function GetNewId() As String
Const ID_PREFIX As String = "LSI-"
Dim IdNumbers()
With ThisWorkbook.Sheets("LSI Log")
Dim EvalString As String
With .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
EvalString = "Value(Right(" & .Address _
& ",LEN(" & .Address & ")-" & Len(ID_PREFIX) & "))"
End With
IdNumbers = .Evaluate(EvalString)
End With
Dim IdNumber, MaxNumber As Long
For Each IdNumber In IdNumbers
If IsNumeric(IdNumber) Then
If IdNumber > MaxNumber Then MaxNumber = IdNumber
End If
Next IdNumber
Dim NewId As String: NewId = ID_PREFIX & CStr(MaxNumber + 1)
GetNewId = NewId
End Function
Your New Sub
Private Sub UserForm_Initialize()
Me.Height = 424
Me.Width = 438
Me.Zoom = 100
Txt_DateLogged.Value = Format(Date, "dd/mm/yyyy")
Txt_Month.Value = Format(Date, "MMM-YY")
Call CBO_Supplier_Items
Call CBO_SRM_Items
Call CBO_Cause_Items
Me.Txt_IssueNum.Value = GetNewId
End Sub

Related

How to check for 2 different values and delete the text where either of these values are found?

I want to find "Ext" and "/" in a column of data and delete all the text after and including those characters
If it doesn't find those characters in my data then exit the sub
I can do them separately but I definitely over complicated it, there must be an easier way
The data column will also have blanks in so I have to avoid blank cells and check the whole range of data
Code
Sub DeleteAfterText()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="Ext")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "Ext")(0)
'ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
Sub DeleteAfterText2()
Dim rngFoundCell As Range
Set rngFoundCell = Sheets("User Load").Range("E1:E3000").Find(What:="/")
'This is checking to see if the range contains EXT, if not it exits the sub'
If rngFoundCell Is Nothing Then 'If no cell in the range has an ' then exist sub
Exit Sub
Else
Worksheets("User Load").Range("E1000").Select 'Start from bottom'
Selection.End(xlUp).Select 'This selects the bottom to the top'
Do Until ActiveCell.Value = "Phone Number" 'This does the change until it reaches the header name'
If ActiveCell.Value = "" Then 'If the cell is blank it skips it as there is no action after the then'
Else
ActiveCell = Split(ActiveCell.Value, "/")(0)
End If
ActiveCell.Offset(-1, 0).Select
Loop
End If
End Sub
This code should work. It is simple to read and easy to understand.
Option Explicit
'The calling Sub
Sub main()
DeleteTextFromColumn ActiveSheet.Range("E1:E3000")
End Sub
Sub DeleteTextFromColumn(ByRef inRange As Range)
Dim cCell As Range
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim strTemp As String
Dim strOut As String
'You can specify which column if more than one column is provided to the
' subroutine. Ex: Range("E1:F3000")
For Each cCell In inRange.Columns(1).Cells
strTemp = cCell.Value
'gets the position of "ext" (case insensitive)
intPos1 = InStr(LCase(strTemp), "ext")
'gets the position of "/"
intPos2 = InStr(strTemp, "/")
strOut = strTemp
If intPos1 > 1 Then
strOut = Mid(strTemp, 1, intPos1 - 1)
ElseIf intPos2 > 1 Then
strOut = Mid(strTemp, 1, intPos2 - 1)
End If
'Outputs the results
cCell.Value = strOut
Next
End Sub
It's best to break out repeated code into a sub which has parameters for the variable parts of the operation.
You can do something like this:
Sub Tester()
Dim theRange As Range
Set theRange = Sheets("User Load").Range("E1:E3000")
RemoveTextAfter theRange, "Ext"
RemoveTextAfter theRange, "/"
End Sub
Sub RemoveTextAfter(rng As Range, findWhat As String)
Dim f As Range
If Len(findWhat) = 0 Then Exit Sub
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Do While Not f Is Nothing
f.Value = Split(f.Value, findWhat)(0)
Set f = rng.Find(What:="Ext", lookat:=xlPart)
Loop
End Sub
I'm going to give you two answers for the price of one. :)
At its root, the basic logic you need to figure out if a substring exists in a given string is a standard part of VBA in the InStr function. Using this, you can break out your logic to check a cell's value and (conditionally) delete the remainder of the string into a function like this:
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
Notice here that using the function created above, we don't need to use Range.Find at all.
Once you have that, your top-level logic consists of setting up the range to search. In all of my code, I explicitly create objects to reference the workbook and worksheet so that I can keep things straight. In a simple example like this, it may seem like overkill, but the habit comes in handy when your code gets more involved. So I set up the range like this
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Now the loop just goes through each cell and gets a (potentially) updated value.
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
So your whole solution looks like this:
Option Explicit
Public Sub TestDirectlyFromRange()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
Dim searchRange As Range
Set searchRange = userLoadWS.Range("E1:E3000")
Dim cell As Variant
For Each cell In searchRange
If Not cell.value = vbNullString Then
Debug.Print cell.Address & " = " & cell.value
cell.value = DeleteTextAfter(cell.value, "Ext")
cell.value = DeleteTextAfter(cell.value, "/")
End If
Next cell
End Sub
Private Function DeleteTextAfter(ByVal contents As String, _
ByVal token As String) As String
'--- searches the given string contents and if it finds the given token
' it deletes the token and all following characters
DeleteTextAfter = contents
Dim pos1 As Long
pos1 = InStr(1, contents, token, vbTextCompare)
If pos1 > 0 Then
DeleteTextAfter = Left(contents, pos1 - 1)
End If
End Function
But wait, there's more!!
You're iterating over 3,000 rows of data. That can get to be slow if all those rows are filled or if you increase the number of rows to search. To speed up the search, the answer is to copy the data in the range to a memory-based array first, modify any of the data, then copy the results back. This example uses the same Function DeleteTextAfter as above and is much quicker. Use whichever one fits your situation best.
Public Sub TestRangeInArray()
Dim thisWB As Workbook
Dim userLoadWS As Worksheet
Set thisWB = ThisWorkbook
Set userLoadWS = thisWB.Sheets("User Load")
'--- create the range and copy into a memory array
Dim searchRange As Range
Dim searchData As Variant
Set searchRange = userLoadWS.Range("E1:E3000")
searchData = searchRange.value
Dim i As Long
For i = LBound(searchData, 1) To UBound(searchData, 1)
If Not searchData(i, 1) = vbNullString Then
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "Ext")
searchData(i, 1) = DeleteTextAfter(searchData(i, 1), "/")
End If
Next i
'--- now copy the modified array back to the worksheet range
searchRange.value = searchData
End Sub

Copy data from one sheet to another in reverse order using vba

I have two sheets in my excel PullData and AllStocks. I would like to copy data from PullData column A and paste the values reverse order into other sheet AllStocks.
Currently, I am using OFFSET function to perform it. But I see a performance issue while running large data set using this method. Is there any better way I can perform this task ?
My CUrrent Code :
Sub GetData()
Dim Main As Worksheet
Dim PullData As Worksheet
Dim AllStocks As Worksheet
Dim i,m As Integer
Set RawImport = Workbooks("vwap.xlsm").Sheets("RawImport")
Set PullData = Workbooks("vwap.xlsm").Sheets("PullData")
m = PullData.Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To m
AllStocks.Range("A2:A" & i).Formula = "=OFFSET(PullData!$A$" & m & ",-(ROW(PullData!A1)-1),0)"
Next i
End Sub
no loop code:
Option Explicit
Sub GetData()
Dim pullDataVals As Variant
With Workbooks("vwap.xlsm")
With .Sheets("PullData")
pullDataVals = Split(StrReverse(Join(Application.Transpose(.Range("A3", .Cells(.Rows.Count, "A").End(xlUp)).Value), ",")), ",")
End With
.Sheets("RawImport").Range("A2").Resize(UBound(pullDataVals) + 1).Value = Application.Transpose(pullDataVals)
End With
End Sub
just check your sheets names: in your question you're speaking about "PullData and AllStocks" but in your code some RawImport sheet is featuring...
or, in a super compressed style:
Sub GetData()
With Workbooks("vwap.xlsm").Sheets("PullData")
With .Range("A3", .Cells(.Rows.Count, "A").End(xlUp))
.Parent.Parent.Sheets("RawImport").Range("A2").Resize(.Rows.Count).Value = Application.Transpose(Split(StrReverse(Join(Application.Transpose(.Value), ",")), ","))
End With
End With
End Sub
should your data in PullData be a more than one character string or more than one digit number, to prevent what Gary's Student remarked, you could use ArrayList object and its Reverse method:
Sub GetData()
Dim arr As Object
Dim cell As Range
Set arr = CreateObject("System.Collections.Arraylist")
With Workbooks("vwap.xlsm")
With .Sheets("PullData")
For Each cell In .Range("A3", .Cells(.Rows.Count, "A").End(xlUp))
arr.Add cell.Value
Next
End With
arr.Reverse
.Sheets("RawImport").Range("A2").Resize(arr.Count) = Application.Transpose(arr.toarray)
End With
End Sub
This solution applies the INDEX formula to a temporary Name.
Sub Range_ReverseOrder()
Const kFml As String = "=INDEX(_Src,#RowsSrc+#RowTrg-ROW(),1)"
Dim nmSrc As Name, rgTrg As Range
Dim lRows As Long, sFml As String
Rem Set Objects
With Workbooks("vwap.xlsm")
lRows = .Worksheets("PullData").Cells(Rows.Count, 1).End(xlUp).Row
Set nmSrc = .Names.Add(Name:="_Src", _
RefersTo:=.Worksheets("PullData").Cells(2, 1).Resize(-1 + lRows, 1))
.Names("_Src").Comment = "Range_ReverseOrder"
Set rgTrg = .Worksheets("RawImport").Cells(2, 1).Resize(-1 + lRows, 1)
End With
Rem Set Formula
sFml = kFml
sFml = Replace(sFml, "#RowsSrc", nmSrc.RefersToRange.Rows.Count)
sFml = Replace(sFml, "#RowTrg", rgTrg.Row)
Rem Apply Formula
With rgTrg
.Offset(-1).Resize(1).Value = "Reverse.Order"
.Formula = sFml
.Value2 = .Value2
End With
Rem Delete Temporary Name
nmSrc.Delete
End Sub

Trying to print the values of all the total number rows from multiple sheets into a column in a results page

another problem... Its driving me nuts!! (I am still very new to vba)
I am trying to count all the rows from multiple sheets into one results page. This is what I have:
Sub CallerSub()
Worksheets("Testing").Column(1).Select.Value = Test_It
End Sub
Function Test_It()
For Each sheet In ThisWorkbook.sheets
Debug.Print sheet.name & vbTab & CountMyRows(sheet.name)
Next sheet
End Function
Function CountMyRows(SName) As Long
Dim rowCount As Long
rowCount = Worksheets(SName).UsedRange.Rows.Count
End Function
The error that is coming up is 'Object does not support this property or method'
Code is mostly from:
Count number of rows in multiple Excel sheets and return values to a "summary" sheet
Edit: Error is on this line:
Worksheets("Testing").Column(1).Select.Value = Test_It
Thank you
A slightly different approach to your set-up, but if all you need is a column containing the count for each tab..
Sub CallerSub()
Dim rw As Long
rw = 0
For Each sht In ThisWorkbook.Sheets
rw = rw + 1
Cells(rw, 1) = CountMyRows(sht.Name)
Next
End Sub
Function CountMyRows(SName As String) As Long
CountMyRows = Sheets(SName).UsedRange.Rows.Count
End Function
Note: This counting process WILL include the sheet that the output is being written to - and as it counts before it writes, it may not be correct. You could exclude a certain sheet with an IF statement..
CountMyRows does not return so is 0, CountMyRows = ThisWorkbook.Worksheets(SName).UsedRange.Rows.Count will make your function return a value.
Sub CallerSub()
Dim a() As Variant
a = Test_It
Worksheets("Testing").Range("a1").Resize(UBound(a) + 1, 1).Value = WorksheetFunction.Transpose(a)
End Sub
Function Test_It() As Variant()
Dim a() As Variant
On Error GoTo eHandle
For Each Sheet In ThisWorkbook.Sheets
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = Sheet.Name & vbTab & CountMyRows(Sheet.Name)
Next Sheet
Test_It = a
Exit Function
eHandle:
If Err.Number = 9 Then
ReDim a(0)
Resume Next
End If
End Function
Function CountMyRows(SName) As Long
Dim rowCount As Long
CountMyRows = Worksheets(SName).UsedRange.Rows.Count
End Function

Detect the last entry in a Column to search for a value within the used range

I am trying to check if a value is in a certain range. If that value appears, the corresponding data to that enty is copied to another sheet. The trick is it has to be dynamically determined because the column size varies from input sheet to input sheet. In Java the hasNext() function can be used. I think that VBA's most similar function would be Sheet1.Column.End(xlup). How is the best way to determine the end of a column for the test condition of a do while loop in vba?
Pseudo example:
'This is part of a nested loop, this segment traverses the column looking for 'specified data.
Do While (!Sheets(inputSheetName).SyntaxToDetermineEndOfColumn))
If(someCell = someValue)
Copy values from the corresponding row to fields in newSheet
End If
Next r 'This increments the row within the current column
Loop
Next c 'This increments to the next column of data
Say we have data like:
We want to find happiness in the first two columns and retrieve the column C value in that row:
Sub LookingForHappiness()
Dim i As Long, j As Long, N As Long, h As String
h = "happiness"
For i = 1 To 2
N = Cells(Rows.Count, i).End(xlUp).Row
For j = 1 To N
If Cells(j, i).Value = h Then
MsgBox Cells(j, "C").Value
MsgBox Cells(j, i).Address(0, 0)
Exit Sub
End If
Next j
Next i
End Sub
There are two parts to your question:
The first part about finding the last used row is easialy found with a quick Google: Error in finding last used cell in VBA
To loop from start to end of column, use this:
Dim ws1 as Worksheet, LastRow as Long, CurRow as Long, DataFind as String
Set ws1 = Sheets("Name of Sheet")
LastRow = ws1.Range("Column letter" & ws1.Rows.Count).End(xlUp).Row
DataFind = Inputbox("What are you looking for?")
For CurRow = 1 to LastRow
If ws1.Range("Column Letter" & CurRow).Value = DataFind Then
ws1.Range("Column Letter" & CurRow).EntireRow.Copy
Sheets("Dest Sheet").Range("Whatever").PasteSpecial
End If
Next CurRow
You might find this useful: http://support.microsoft.com/kb/830287
But what I personally do in this situation involves a bit more code, but is flexible and fast. First create a class and call it "RangeInfo". Then past this:
Option Explicit
Private Type Properties
Intialized As Boolean
Object As Excel.Range
RowBottom As Long
RowCount As Long
RowTop As Long
ColumnLeft As Long
ColumnCount As Long
ColumnRight As Long
End Type
Private this As Properties
Public Property Get Initialized() As Boolean
Initialized = this.Intialized
End Property
Public Property Get Object() As Excel.Range
Set Object = this.Object
End Property
Public Property Get ColumnLeft() As Long
ColumnLeft = this.ColumnLeft
End Property
Public Property Get ColumnCount() As Long
ColumnCount = this.ColumnCount
End Property
Public Property Get ColumnRight() As Long
ColumnRight = this.ColumnRight
End Property
Public Property Get RowBottom() As Long
RowBottom = this.RowBottom
End Property
Public Property Get RowCount() As Long
RowCount = this.RowCount
End Property
Public Property Get RowTop() As Long
RowTop = this.RowTop
End Property
Public Sub Initialize(ByRef rng As Excel.Range)
With this
Set .Object = rng
.RowTop = rng.row
.RowCount = rng.Rows.Count
.RowBottom = .RowTop + .RowCount - 1&
.ColumnLeft = rng.Column
.ColumnCount = rng.Columns.Count
.ColumnRight = .ColumnLeft + this.ColumnCount - 1&
.Intialized = True
End With
End Sub
Public Sub Clear()
Dim emptyProperties As Properties
this = emptyProperties
End Sub
Private Sub Class_Terminate()
Set this.Object = Nothing
End Sub
Then for your code, use this:
Option Explicit
Public Sub Example()
'Set these as needed:
Const sheetName As String = "MySheet"
Const columnNumber As Long = 2&
Const criteria As String = "*foo#"
Dim wsIn As Excel.Worksheet
Dim wbOut As Excel.Workbook
Dim wsOut As Excel.Worksheet
Dim ri As RangeInfo
Dim rowIn As Long
Dim rowOut As Long
Dim col As Long
Set wbOut = Excel.Workbooks.Add
Set wsOut = wbOut.Worksheets(1)
Set wsIn = Excel.Worksheets(sheetName)
Set ri = New RangeInfo
ri.Initialize wsIn.UsedRange
rowOut = 1&
With ri
For rowIn = .RowTop To .RowBottom
If wsIn.Cells(rowIn, columnNumber) Like criteria Then
rowOut = rowOut + 1&
For col = .ColumnLeft To .ColumnRight
wsOut.Cells(rowOut, col).Value = wsIn.Cells(rowIn, col).Value
Next
End If
Next
End With
End Sub

Adding another row with data

I've looked hight and low for a correct method, but I'm having so much trouble.
I'm trying to add another row with data on the end of my table, but all it keeps doing is adding another row but doesn't add the actual data.
Sub CommandButton1_Click()
Dim lastRow As Long
Dim iHeader As Integer
Dim strData As String
strname = InputBox(prompt:="Enter data")
Set myTable = ActiveSheet.ListObjects("Table1")
ActiveSheet.ListObjects("Table1").ListRows.Add
With ActiveSheet.ListObjects("Table1")
lastRow = ActiveSheet.ListObjects("Table1").ListRows.Count
End With
ActiveSheet.Cells(lastRow, "M").Value = strData
End Sub
It will only add a row to the table but it will not add the strData value no matter what I try. The Column its using for testing purposes is "M"
Any help would be appreciated
Looks like a typographical error: (Which is why you should always use Option Explicit)
Option Explicit
Sub CommandButton1_Click()
Dim lastRow As Long
Dim iHeader As Integer
Dim strData As String
strData = InputBox(prompt:="Enter data") 'Fixed variable here
Set myTable = ActiveSheet.ListObjects("Table1")
With myTable
.ListRows.Add
lastRow = .ListRows.Count
End With
ActiveSheet.Cells(lastRow, "M").Value = strData
End Sub