Add a text to an existing cell - excel

I'm trying to create a function in VBA to add a text to an existing cell.
, 
I want to add "Brand" to cells in the first column. I want to use this function in any cell where I enter the formula.
I'm very new to VBA. I tried searching the internet but couldn't find a simple solution for my level. Could anyone please help me with this? 
Thank you

Add a new module in the Visual Basic Editor (VBE).
Add this code to the module:
Option Explicit
Public Sub Add_Brand()
Dim Cell As Range
For Each Cell In Selection
Cell = "Brand " & Cell
Next Cell
End Sub
Select a range of cells, go to View > Macros on the toolbar and run the Add_Brand macro.
Edit: I should add that if the selected range of cells contain a formula then this will overwrite the formula with the new value.
Edit 2: If you did have formula (not an array formula) I guess you could use this code....
Public Sub Add_Brand()
Dim Cell As Range
For Each Cell In Selection
If Cell.HasFormula Then
Cell.Formula2 = "=""Brand "" & " & Mid(Cell.Formula2, 2, Len(Cell.Formula2))
Else
Cell = "Brand " & Cell
End If
Next Cell
End Sub

A Worksheet Change: Add a Prefix
The following code needs to be copied to the sheet module of the worksheet where it is meant to be applied e.g. Sheet1 (not in a standard module e.g. Module1 nor in the ThisWorkbook module).
It runs automatically: whatever you attempt to write to A2:A1048576 gets the "Brand " prefix.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const FIRST_CELL As String = "A2"
Const PREFIX As String = "Brand "
On Error GoTo ClearError
Dim trg As Range
With Me.Range(FIRST_CELL)
Set trg = .Resize(Me.Rows.Count - .Row + 1)
End With
Dim irg As Range: Set irg = Intersect(trg, Target)
If irg Is Nothing Then Exit Sub
Dim pLen As Long: pLen = Len(PREFIX)
Dim iCell As Range, iString As String
Application.EnableEvents = False
For Each iCell In irg.Cells
iString = CStr(iCell.Value)
If Len(iString) > 0 Then
'If InStr(1, iString, PREFIX, vbTextCompare) <> 1 Then
iCell.Value = PREFIX & iString
'End If
End If
Next iCell
ProcExit:
On Error Resume Next
If Not Application.EnableEvents Then Application.EnableEvents = True
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "':" & vbLf & Err.Description
Resume ProcExit
End Sub

Select the first cell you want to change before running the code.
Sub insertBrand()
Do While ActiveCell.Value <> ""
ActiveCell.Value = "Brand " & ActiveCell.Value
Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate
Loop
End Sub

Related

change the range of function automatically when rows are added

[1
I wrote =sum(A2:A11) in cell A1, and I wrote random numbers in A2:A11. Then I deleted some rows and then the A1 cell's range changed automatically. But I don't understand why the range does not change automatically when I add new rows and intert new values. How can I make it change automatically? Do I have to use vba to do this?
A Worksheet Change Event: Monitor Change in Column's Data
I personally would go with JvdV's suggestion in the comments.
On each manual change of a cell, e.g. in column A, it will check the formula
=SUM(A2:ALastRow) in cell A1 and if it is not correct it will overwrite it with the correct one.
You can use this for multiple non-adjacent columns e.g. "A,C:D,E".
Nothing needs to be run. Just copy the code into the appropriate sheet module e.g. Sheet1 and exit the Visual Basic Editor.
Sheet Module e.g. Sheet1 (not Standard Module e.g. Module1)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
UpdateFirstRowFormula Target, "A"
End Sub
Private Sub UpdateFirstRowFormula( _
ByVal Target As Range, _
ByVal ColumnList As String)
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim Cols() As String: Cols = Split(ColumnList, ",")
Application.EnableEvents = False
Dim irg As Range, arg As Range, crg As Range, lCell As Range
Dim n As Long
Dim Formula As String
For n = 0 To UBound(Cols)
With ws.Columns(Cols(n))
With .Resize(.Rows.Count - 1).Offset(1)
Set irg = Intersect(.Cells, Target.EntireColumn)
End With
End With
If Not irg Is Nothing Then
For Each arg In irg.Areas
For Each crg In arg.Columns
Set lCell = crg.Find("*", , xlFormulas, , , xlPrevious)
If Not lCell Is Nothing Then
Formula = "=SUM(" & crg.Cells(1).Address(0, 0) & ":" _
& lCell.Address(0, 0) & ")"
With crg.Cells(1).Offset(-1)
If .Formula <> Formula Then .Formula = Formula
End With
End If
Next crg
Next arg
Set irg = Nothing
End If
Next n
SafeExit:
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
Use a nested function as below:
=SUM(OFFSET(A2,,,COUNTA(A2:A26)))

How can I get this Excel VBA to run for all rows, instead of just the first row?

So darn new to VBA, almost got this working. I'm trying to reset some Data Validation lists so that if someone changes a Country selection, then a couple of cells will reset. Example, if I pick USA then I want the corresponding State and Shift column to display "Please select..." and if the user changes the country to something other than USA then it doesn't say anything in the State column, only in the Shift column. I got this working but it only runs for the first row. I'm not sure if my range is wrong or if I'm supposed to loop, both of which I'm totally ignorant on.
Option Explicit
'The way this works is if the Payroll Country changes then the sub selections
'of State and Shift should reset based on if the country is USA
'Payroll Country = A column
'State = X column
'Shift = Y column
Private Sub Worksheet_Change(ByVal Target As Range)
'"If Target.Count > 1 Then Exit Sub" is the VBA code to prevent an error if user highlights the range and deletes the data
If Target.Count > 1 Then Exit Sub
If Target.Address = "$A$6" And Target.Value = "USA" Then
Range("X6").Value = "Please select..."
Range("Z6").Value = "Please select..."
ElseIf Target.Address = "$A$6" And Target.Value <> "USA" Then
Range("X6").Value = ""
Range("Z6").Value = "Please select..."
End If
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub 'CountLarge handles larger ranges...
'check Target column and row...
If Target.Column = 1 and Target.Row >= 6 Then
With Target.EntireRow
.Columns("X").Value = IIf(Target.Value = "USA", _
"Please select...", "")
.Columns("Z").Value = "Please select..."
End With
End If
End Sub
A Worksheet Change
If you out-comment the line Application.EnableEvents = False you will notice that there will be more Debug.Print lines (one more for USA, two more for non-USA) i.e. after writing (crg.Value = InitialString), the code calls itself (actually the worksheet change event calls the InitializeCountry procedure) again but 'luckily' exits after the line If irg Is Nothing Then Exit Sub since it is writing to a non-intersecting range, but nevertheless debug-printing the Source Range Address once more, before it continues with the line Debug.Print "Criteria Range (Both Columns): " & crg.Address(0, 0). This should help you to fully understand why the disabling of events is necessary.
Out-comment or delete the range addresses related Debug.Print lines when done testing because they're slowing down the code.
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
InitializeCountry Target
End Sub
Standard Module e.g. Module1
Option Explicit
Sub InitializeCountry( _
ByVal Target As Range)
' Declare constants.
Const SourceFirstCellAddress As String = "A6"
Const StateColumn As String = "X"
Const ShiftColumn As String = "Z"
Const CriteriaString As String = "USA"
Const InitialString As String = "Please select..."
' Read.
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim sfCell As Range: Set sfCell = ws.Range(SourceFirstCellAddress)
Dim srg As Range: Set srg = sfCell.Resize(ws.Rows.Count - sfCell.Row + 1)
Debug.Print "Source Range Address: " & srg.Address(0, 0)
Dim irg As Range: Set irg = Intersect(srg, Target) ' Intersect Range
If irg Is Nothing Then Exit Sub
Debug.Print "Intersect Range Address: " & irg.Address(0, 0)
' ShiftColumn
Dim crg As Range ' Criteria Range
Set crg = irg.EntireRow.Columns(ShiftColumn)
Debug.Print "Criteria Range (ShiftColumn): " & crg.Address(0, 0)
' StateColumn
Dim erg As Range ' Empty Range
Dim iCell As Range ' Current Intersect Cell
For Each iCell In irg.Cells
If iCell.Value = CriteriaString Then
Set crg = Union(crg, iCell.EntireRow.Columns(StateColumn))
Else
If erg Is Nothing Then
Set erg = iCell.EntireRow.Columns(StateColumn)
Else
Set erg = Union(erg, iCell.EntireRow.Columns(StateColumn))
End If
End If
Next iCell
' Write.
Application.ScreenUpdating = False
' This is crucial to not retrigger the event procedure when writing!
Application.EnableEvents = False
On Error GoTo ClearError
crg.Value = InitialString
Debug.Print "Criteria Range (Both Columns): " & crg.Address(0, 0)
If Not erg Is Nothing Then
erg.ClearContents ' erg.Value = Empty
Debug.Print "Empty Range (StateColumn): " & erg.Address(0, 0)
End If
SafeExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
ClearError:
' Don't uncomment this line!
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
' Test multi-range (only possible with VBA).
Sub InitializeCountryTEST()
Dim rg As Range: Set rg = Range("A6:A20,A31:A50,A61:A100")
rg.Value = "USA"
End Sub
' Debug.Print result for 'USA' (no 'Empty Range'):
'Source Range Address: A6:A1048576
'Intersect Range Address: A6:A20,A31:A50,A61:A100
'Criteria Range(ShiftColumn): Z6:Z20
'Criteria Range (Both Columns): Z6:Z20,X6:X20,X31:X50,X61:X100
' Debug.Print result otherwise:
'Source Range Address: A6:A1048576
'Intersect Range Address: A6:A20,A31:A50,A61:A100
'Criteria Range(ShiftColumn): Z6:Z20
'Criteria Range (Both Columns): Z6:Z20
'Empty Range (StateColumn): X6:X20,X31:X50,X61:X100

How do I execute instructions only if the cell value change?

I have a ByVal code to clear the contents of a specific range inside a table, it works. But I need to add a condition for the instructions execute if the RANGE VALUE (content) change, not if I only place the cursor on it.
Also, someone knows how to reference a table column in VBA? Now I'm using an estimated range "C1:C999" but I'll like to use his name "A_[OPERATION]".
This is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("C1:C999"), Range(Target.Address)) Is Nothing Then
Range(Selection, Selection.End(xlToRight)).ClearContents
End If
End Sub
You could use the change event instead.
Here's a link to the documentation:
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.change
Alternatively, you could save the value of your target cell in a variable and check if the value changed before executing your clear contents.
For your second question, you should probably ask about it in a separate post.
A Worksheet Change
Adjust the table name (tName) and the header (column) name (hName).
I have adjusted it to clear contents in the cells after the column.
If you really need to clear the contents of the column too, then replace cel.Offset(, 1) with cel.
In a table, the current setup will automatically clear the contents of all the cells to the right of the specified column, if a value in the column is manually or via VBA changed. This will not work if the column contains formulas. Non-contiguous deletions are also supported.
The code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ProcName As String = "Worksheet_Change"
On Error GoTo clearError
Const tName As String = "A_"
Const hName As String = "OPERATION"
Dim rng As Range
Set rng = Range(tName & "[" & hName & "]")
Set rng = Intersect(rng, Target)
If rng Is Nothing Then GoTo ProcExit
Application.EnableEvents = False
With ListObjects(tName).HeaderRowRange
Dim LastColumn As Long
LastColumn = .Columns(.Columns.Count).Column
End With
Dim cel As Range
For Each rng In rng.Areas
For Each cel In rng.Cells
With cel.Offset(, 1)
.Resize(, LastColumn - .Column + 1).ClearContents
End With
Next cel
Next rng
CleanExit:
Application.EnableEvents = True
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo CleanExit
ProcExit:
End Sub
A change in cell value is captured by the Worksheet_Change event-handle.
However, this handle will trigger even if it is a false change. For example, if the cell value before the change is "A", and user just entered "A" again in the cell, the Change event procedure will be triggered anyhow.
To avoid this, we can use Worksheet_Change and Worksheet_SelectionChange together.
Using Worksheet_SelectionChange, we record the old value somewhere, say a Name. Then using Worksheet_Change, we can compare what the user has entered against the Name to see if a true change is made.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Count = 1 Then
'This only record one old cell value.
'To record multiple cells old value, use a hidden Worksheet to do so instead of a Name.
Nm.Comment = Target.Value2
else
Nm.Comment = Target.Value2(1, 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Value2 <> Nm.Comment Then
Debug.Print "True change"
Else
Debug.Print "False change"
End If
End Sub
You can access a table's methods and properties through the listobject object. Below is an example how to do so.
Sub Example()
Dim lo As ListObject
Dim lc As ListColumn
Set lo = Range("Table1").ListObject
Set lc = lo.ListColumns("Column2")
End Sub
That said, for your case, it would be Range("A_").ListObject.ListColumns("OPERATION").DataBodyRange.

Identifying cells that are empty or showing #REF! error in a given range

My code is not working properly. It's only showing the first empty cell T10 but cells from T10 to T15 are all empty. I would also like to identify cells that are showing #REF! in them. I don't need the address of empty cells (as there could be quite a few on bigger scale) but would like to know the address of cells with #REF! Thank you!
Sub Identiycells()
Dim Cancel As Boolean
Dim cell As Range
Dim sh As Worksheet
For Each sh In ThisWorkbook.Worksheets(Array("a", "b"))
For Each cell In sh.Range("T6:T18")
If IsEmpty(cell) 'Or showing #REF! Then
MsgBox "Data Missing or Formula error" & cell.Address
Application.Goto cell, True
Cancel = True
Exit For
End If
Next cell
Next sh
End Sub
You could collect the errors in a String and only report once at the end. For checking #REF or other errors you can test with IsError(cell.value).
As you are going through different sheets, it might be good to specify which sheet the cells are on. You can get a cell reference including its sheet with Split(cell.address(External:=True), "]")(1).
Suggested code:
Sub Identiycells()
Dim Cancel As Boolean
Dim cell As Range
Dim sh As Worksheet
Dim report as String ' collect all errors
Dim errorMsg as String ' error for current cell
Dim errorCell as Range ' cell to focus at the end
For Each sh In ThisWorkbook.Worksheets(Array("a", "b"))
For Each cell In sh.Range("T6:T18")
errorMsg = ""
If IsEmpty(cell) Then
errorMsg = "Data Missing"
If errorCell Is Nothing Then Set errorCell = cell
ElseIf IsError(cell.value) Then
errorMsg = "Invalid Reference"
Set errorCell = cell
End If
If errorMsg <> "" Then
report = report & errorMsg & " in " & _
Split(cell.address(External:=True), "]")(1) & vbCrLf
End If
Next cell
Next sh
If Not errorCell Is Nothing Then
MsgBox report
Application.Goto errorCell, True
Cancel = True
End If
End Sub

vba#excel_highlight the empty cells

I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub

Resources