Finding a cell based on the header of a section of data, then selecting the last row of that section - vba

I am attempting to find the text of a header row based on the value of a cell relative to the cell that is clicked in. The way I have attempted to do this is follows:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim var1 As Variant
Dim var2 As Variant
Dim var3 As Variant
Dim FormName As String
FormName = "New Form"
Static NewFormCell As Range
Application.ScreenUpdating = False
If Not Intersect(Target, Range("G16:X80")) Is Nothing Then
If Target.Cells.Count = 1 Then
var1 = Cells(Target.Row, 2).Value
var2 = Cells(15, Target.Column).Value
If Not (IsEmpty(var1)) And Not (IsEmpty(var2)) And var2 <> "+" And Target.Interior.ColorIndex <> 2 And Target.Borders(xlEdgeLeft).LineStyle <> xlNone Then
If IsEmpty(Target) Then
Target.Value = "X"
Target.HorizontalAlignment = xlCenter
Target.VerticalAlignment = xlCenter
Target.Font.Bold = True
Dim Header As Range
Set Header = Range("A54:E160").Find(var2, LookIn:=xlValues)
Header.Offset(1, 1).End(xlDown).EntireRow.Select
Dim CopyCell As Range
'Header.End(xlDown).EntireRow.Insert
'Set CopyCell = Header.End(xlDown). [offset?]
'CopyCell.Value = var1
Else
Target.ClearContents
End If
Else
Exit Sub
End If
End If
End If
Application.ScreenUpdating = True
End Sub
The issue is VBA is throwing Run-Time Error 91 ("Object variable or With block variable not set"). It then highlights the last row in that section of code. Since I set that variable in the previous line, I'm not sure why I'm receiving this error or if I'm even going about this the right way.
Any input would be greatly appreciated!
EDIT: I cleared the above issue by searching over a wider range. The cell I wanted to select was merged, but I still assumed the value was stored within column A. But this code still isn't quite doing what I'd like it to:
I want to select the last row in the section (not the last row of data in the sheet, but the last contiguous data in column B), but right now my code is jumping me all the way to the bottom of the sheet.

The problem is that your .Find isn't finding the value. In this case, you can add some code to handle that.
...
Dim Header As Range
Set Header = Range("A59:A159").Find(var2, LookIn:=xlFormulas)
If Header Is Nothing Then
' There's no value found, so do something...
msgbox(var2 & " was not found in the range, will exit sub now."
Exit Sub
End If
MsgBox Header
...
...of course there are myriad ways/things you can do to handle this. If you still want to execute other code, then wrap everything in an If Header is Nothing Then // 'do something // Else // 'other code // End IF type thing.
It really just depends on what you want to do. Again, your error is being caused by the fact that the var2 isn't being found, so just find other things to do in that case.

Related

Finding a value in the range

I am writing a subroutine that looks through a range of cells starting in cell A1 (the range is 1 column wide) containing String values. My sub first finds the entire range and assign it to a Range variable "theForest" to help make searching easier. Then, it looks through each cell in the range until it finds the word “Edward”. If he is found or not, it display the result in a message (stating that he was or was not found).
The code I have so far is this:
With Range("A1")
'this will help find the entire range, since it is only one column I will search by going down
theForest = Range(.Offset(0,0), .End(xlDown)).Select
Dim cell As Range
For Each cell In theForest
If InStr(Edward) Then
Msgbox"He was found"
Else
Msgbox"He was not found sorry"
End If
Next cell
End With
However I am getting numerous errors upon running the program and I think the issue is with the
theForest = Range(.Offset(0,0), .End(xlDown.)).Select
line of code. I would appreciate any guidance into this simple code.
Thank you :)
EDIT: Here is some new code I have come up with:
Dim isFound As Boolean
isFound = False
With Range("A1")
For i = 1 to 500
If .Offset(1,0).Value = "Edward" Then
isFound = True
Exit For
End If
Next
End With
If isFound = True Then
Msgbox " Edward was found"
Else
MsgBox "Edward was not found"
End if
Then again it does not include finding the entire range and assiging it to the range variable theForest.
Dim theForest as Range, f as Range
Set theForest = ActiveSheet.Range(ActiveSheet.Range("A1"), _
ActiveSheet.Range("A1").End(xlDown))
Set f = theForest.Find("Edward", lookat:=xlWhole)
If Not f Is Nothing Then
Msgbox"He was found"
Else
Msgbox"He was not found sorry"
End If

Why does autofit row VBA code in Excel keep causing #value error in my formula?

I have a concatenate based on offset array code that I'm using to combine data.
Public Function concatPlusIfs(rng As Range, sep As String, lgCritOffset1 As Long, lgCritOffset2 As Long, varCrit1 As Variant, lgCritOffset3 As Long, lgCritOffset4 As Long, varCrit2 As Variant, Optional noDup As Boolean = False, Optional skipEmpty As Boolean = False) As String
Dim CL As Range, strTemp As String
If noDup Then 'remove duplicates, use collection to avoid them
Dim newRow As New Collection
On Error Resume Next
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then newRow.Add CL.Text, CL.Text
End If
Next
For i = 0 To newRow.Count
strTemp = strTemp & newRow(i) & sep
Next
Else
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then strTemp = strTemp & CL.Text & sep
End If
Next
End If
concatPlusIfs = Left(strTemp, Len(strTemp) - Len(sep))
End Function
The code works great. It's not mine, but I tweaked someone else's code. The problem is that it will sometimes return a small amount of text and other times a large amount of text. I need the rows to autofit height. Before I started using the new concatPlusIfs formula, I used a code on the worksheet to autofit row height, but it cause a weird problem with the above code and only the above code and I can't find any mention of this type of problem. It works fine with all other arrays or non array formulas that I'm using. Basically what happens is that for a fraction of a second I can see the correct output in the cell and then I get #value!. I have no idea what's going on. I've tried autofit rows as a macro instead and it had the same effect. If I manually autofit the row everything is fine, but that's not a viable option.
Does anyone understand what would cause a problem like this? Or How can I fix it?
I'm not using any merged rows anywhere on the sheet.
Here are a few of the autofit strategies I've tried. One as a macro:
Sub AutoFit()
Worksheets("Sheet1").Range("A2:A" & Rows.Count).Rows.AutoFit
End Sub
Also as a code on the sheet,
Private Sub Worksheet_Change(ByVal Target As Range)
Target.EntireRow.AutoFit
End Sub
And,
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
Me.Rows.AutoFit
'or be specific
Me.Rows("1:33").AutoFit
Application.EnableEvents = True
End Sub
Thank you for any help with this.
You most likely get #VALUE! error when your formula tries to convert the ### from the .Text property to value. That is why you should use .Value2 or .Value instead.

VBA Record date of row change in specific column

I'm trying to automatically update the "Updated" column of an excel spreadsheet when any cell of that specific row changes to today's date. I was able to do this by hard-coding where the "Updated" column header would be, however, it is now necessary to search for that column header as it may move.
The code I am trying to implement works but immediately gives me the error Automation error - The object invoked has disconnected from it's clients.
Any help would be appreciated. Here is the code I have currently:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If Not f Is Nothing Then
Range(Split(f.Address, "$")(1) & Target.Row).Value = Now
Else
MsgBox "'Updated' header not found!"
End If
End If
End Sub
You got into an endless loop.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
Dim f As Range
Set f = ActiveSheet.Range("A1:DD1").Find("Updated", lookat:=xlWhole)
' f.Row = Range(Target).Row
If f Is Nothing Then
MsgBox "'Updated' header not found!"
ElseIf Intersect(Target, f.EntireColumn) Is Nothing Then
Intersect(Target.EntireRow, f.EntireColumn).Value = Now
' Else
' MsgBox "We entered this function again because the row above updated the Updated column", vbInformation, "False alarm"
End If
End If
End Sub
To understand what happens,
Uncomment the else and MsgBox
Put a breakpoint on the MsgBox
When you hit it, press [ctrl]-L
In a case such as this, I run into far fewer problems when I simply loop through the available cells to find the column header. Using the .Find method also works, but is less "tunable" to my needs in a custom application.
Public Function FindColumn(header As String) As Long
Dim lastCol As Long
Dim headerCol As Long
Dim i As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VTO2 Labor")
lastCol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
headerCol = 0
For i = 1 To lastCol
If sh.Cells(1, i).Value = header Then
headerCol = i
End If
Next i
FindColumn = headerCol
End Function
It isn't clear on whether the Updated column header could be in row 1 or if it will always be in row 1, just not in the same location.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:DX")) Is Nothing Then
On Error GoTo bm_SafeExit
'TURN OFF EVENTS IF YOU ARE GOING TO WRITE A VALUE INTO THE WORKSHEET!
Application.EnableEvents = False
Dim uCol As Long, f As Range
If Application.CountIf(Rows(1), "updated") Then
uCol = Application.Match("updated", Rows(1), 0)
For Each f In Intersect(Target, Range("A:DX"))
If f.Row > 1 Then _
Cells(f.Row, uCol) = Now
Next f
Else
MsgBox "'Updated' header not found!"
End If
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
That should survive multiple updates (e.g. when pasting values). The problem I see is that is the Updated column is being shifted around, presumably through inserting columns or the like, then the change routine is going to run.

Coding for In/Out Tracking of Tools with no repeating and text always getting added into and not deleted text input by barcode scanner

I am trying to make a code in Microsoft Excel Where it puts a text into a cell when another cell is filled in.
What I am looking for is that when cell A for example is filled cell C is filled in with OUT. Then when cell A is filled in again on the next line or another line below it cell C on the same line as cell A is filled in with IN.
We would like to utilize a barcode scanner for checking the tools in and out. I already figured out how to get the barcode to scan into column A
I would like this process to be repeated over and over again.
It's supposed to be a tracking sheet for when tools get taken out and get put back into stock. The text is going to constantly be added and nothing deleted. We want to utilize a barcode scanner to check tools in and out. The employees scan their barcode indicating them then they scan the tool indicating what tool they are taking. Then when they come back they scan their barcode again and then they scan the tool back into inventory. Of course just having this simple setup will lead to a mess of whether the tool is in or out and who used it last since we have a bunch of employees taking tools IN and OUT constantly. That way we can be sure of who used what tool last and whether it's IN or OUT.
Below I have the coding that I need for the time stamp.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim B As Range, AC As Range, t As Range
Set B = Range("B:B")
Set AC = Range("A:A")
Set t = Target
If Intersect(t, AC) Is Nothing Then Exit Sub
Application.EnableEvents = False
Range("B" & t.Row).Value = Now
Application.EnableEvents = True
End Sub
It sounds like a very contrived example for asking the question "In VBA, how do I fill an Excel cell with a specific string?"
The answer to that question is:
myRange.Value = "<myString>"
Anyway, this is how I would try to tackle your problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim xlCell As Range
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
For Each xlCell In rngIntersect
If xlCell.Value = "" Then
inOut = "OUT"
Else
inOut = "IN"
End If
xlCell.Offset(0, 1).Value = Now
xlCell.Offset(0, 2).Value = inOut
Next xlCell
Application.EnableEvents = True
End If
End Sub
Edit:
In response to the asker's comments, the following modified code should address the problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
If rngIntersect.Row = 1 Then
inOut = "OUT"
ElseIf rngIntersect.Offset(-1, 2).Value = "OUT" Then
inOut = "IN"
Else
inOut = "OUT"
End If
rngIntersect.Offset(0, 1).Value = Now
rngIntersect.Offset(0, 2).Value = inOut
Application.EnableEvents = True
End If
End Sub
Edit2:
Use this to loop backwards through your log to determine the previous bookiung status for a specific id:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim xlCell As Range
Dim scanId As String
Dim inOutOld As String
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
scanId = rngIntersect.Value
Set xlCell = rngIntersect
If rngIntersect.Row = 1 Then
inOut = "OUT"
Else
Do Until xlCell.Row = 1
Set xlCell = xlCell.Offset(-1, 0)
If xlCell.Value = scanId Then
inOutOld = xlCell.Offset(0, 2).Value
Exit Do
End If
Loop
End If
If inOutOld = "IN" Then
inOut = "OUT"
Else
inOut = "IN"
End If
rngIntersect.Offset(0, 1).Value = Now
rngIntersect.Offset(0, 2).Value = inOut
Application.EnableEvents = True
End If
End Sub
Instead of using VBA, you could do this with a worksheet 'IF()' formula.
=IF(A3="","","OUT")
=IF(A4="","","IN")
To break it down, this means that if cell A3 = nothing ("") then put nothing ("") in cell C3, but if there is something in cell A3, then put "OUT".
Place the first formula in cell C3 and the second one in C4. If the user of the tool inputs their initials/name in cell A3 then cell C3 will say OUT. It's not until the user comes back and returns the tool and enters their initials/name in cell A4 that cell C4 will say IN.
Hope this simple, non-VBA, example helps!

In a specific row of a table replace a "*" with a checked checkbox, and "" with a checkbox that is not checked

I have a couple of tables and want to replace column 2 or column 5 (if it exists) with check boxes.
If there is an asterisk in the cell, I want the check box checked = True.
If there's no asterisk, the cell will only be a unchecked check box. These check boxes are from the developer tab, under controls, legacy forms.
I researched but failed:
replacing an asterisk with a check box (checked)
limiting it to a specific column (see image)
replacing a blank cell with a check box (unchecked)
limiting the action to a specific column (2 and 5 (if it exists))
Dim oCell As Cell
Dim oRow As Row
For Each oRow In Selection.Tables(1).Rows
For Each oCell In oRow.Cells 'this won't work specifically with my example, needs to be a little more specific
If oCell.Range.Text = "*" Then
MsgBox oCell.RowIndex & ", " & oCell.ColumnIndex & " check it!"
'I don't how to put in a check box here
End If
Next oCell
Next oRow
'I want to combine the top code and code below...right?
'do for each cell in column 2
With ActiveDocument.FormFields.Add(Range:=ActiveDocument.Selection, Type:=wdFieldFormCheckBox)
If cellvalue = "" Then 'just verbal logic here
.CheckBox.Value = False
End If
If cellvalue = "*" Then 'just verbal logic here
.checkbox.Value = True
End If
End With
Here's how I would do this:
Dim objDoc As Document
Dim oCell As Cell
Dim oCol As Column
Dim objTable As Table
Dim bFlag As Boolean
Set objDoc = ActiveDocument
Set objTable = Selection.Tables(1)
'This may or may not be necessary, but I think it's a good idea.
'Tables with spans can not be accessed via the spanned object.
'Helper function below.
If IsColumnAccessible(objTable, 2) Then
For Each oCell In objTable.Columns(2).Cells
'This is the easiest way to check for an asterisk,
'but it assumes you have decent control over your
'content. This checks for an asterisk anywhere in the
'cell. If you need to be more specific, keep in mind
'that the cell will contain a paragraph return as well,
'at a minimum.
bFlag = (InStr(oCell.Range.Text, "*") > 0)
'Delete the content of the cell; again, this assumes
'the only options are blank or asterisk.
oCell.Range.Delete
objDoc.FormFields.Add Range:=oCell.Range, Type:=wdFieldFormCheckBox
'Set the value. I found some weird results doing this
'any other way (such as setting the form field to a variable).
'This worked, though.
If bFlag Then
oCell.Range.FormFields(1).CheckBox.Value = True
End If
Next oCell
End If
'Then do the same for column 5.
Public Function IsColumnAccessible(ByRef objTable As Table, iColumn As Integer) As Boolean
Dim objCol As Column
'This is a little helper function that returns false if
'the column can't be accessed. If you know you won't have
'any spans, you can probably skip this.
On Error GoTo IsNotAccessible
IsColumnAccessible = True
Set objCol = objTable.Columns(iColumn)
Exit Function
IsNotAccessible:
IsColumnAccessible = False
End Function