So I'm writing some VBA code that goes through my document and looks for where a formula returns an error and it merges and centers it with the cell that's underneath it.
Private Sub CommandButton22_Click()
Dim strTemp As String
Dim ev As Variant
Dim rng As Range, cell As Range
Set rng = Range("H87:H89")
For Each cell In rng
If (cell.HasFormula) Then
cell.Select
strTemp = ActiveCell.Formula
ev = Evaluate(strTemp)
If (IsError(ev)) Then
ActiveCell.Clear
ActiveCell.Merge ([0,1])
End If
End If
Next cell
End Sub
This is what I have so far, it clears the cell properly but won't merge.
Try using:
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row + 1, ActiveCell.Column)).Merge
Hope it helps.
Something like this. Note you rarely need select/activate and should try to avoid it as much as possible.
Private Sub CommandButton22_Click()
Dim cell As Range
For Each cell In Range("H87:H89").Cells
If cell.HasFormula Then
If IsError(cell.Value) Then
cell.Clear
cell.Resize(2, 1).Merge
End If
End If
Next cell
End Sub
Related
In my office we tally bags with a barcode scanner, but some times the user edits the Excel cell, giving the bag number manually, so I want to stop manually writing in excel cell.
That cell must update only by scanner.
I've tried the code below, and it returns the keystroke count but not the time.
Private Sub Worksheet_Change(ByVal Target As Range)
'If Target.Address = Range("A1:A100") Then
'Enter Code or Call any Function if any process has to be performed
'When someone Edits the cell A1
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value = "" Then
Call Demo
Else: End If
End Sub
Sub Demo()
'Specify a range (change to suit)
MsgBox CountKeystrokes(Sheets("Sheet1").Range("A:A"))
If Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Offset.Value <> "" Then
Range(ActiveCell, ActiveCell.Offset(numRows, numCols)).Select
Selection.ClearContents
Else
End If
End Sub
Function CountKeystrokes(rng As Range) As Long
Dim rCell As Range
Dim iCtr As Long
For Each rCell In rng
iCtr = iCtr + Len(rCell.Formula)
Next
CountKeystrokes = iCtr
End Function
guys!
At this time I created an UserForm to change the letters on my text using three options:
Uppercase
Lowercase
Proper Function
My first code used the If-Then structure and it was ok. I put it below:
Private Sub OkButton_Click()
Dim WorkRange As Range
Dim cell As Range
'Detects only constant type (text; excludes formulas)
On Error Resume Next
Set WorkRange = Selection.SpecialCells(xlCellTypeConstants, xlCellTypeConstants)
'Uppercase
If OptionUpper Then
For Each cell In WorkRange
cell.Value = UCase(cell.Value)
Next cell
End If
'Uppercase
If OptionLower Then
For Each cell In WorkRange
cell.Value = LCase(cell.Value)
Next cell
End If
'Using Proper Function
If OptionProper Then
For Each cell In WorkRange
cell.Value = Application.WorksheetFunction.Proper(cell.Value)
Next cell
End If
Unload UserForm1
End Sub
Private Sub UserForm_Click()
End Sub
I used a mode to run the UserForm1:
Sub ChangeCase2()
If TypeName(Selection) = "Range" Then
UserForm1.Show
Else
MsgBox "Selection a range.", vbCritical
End If
End Sub
And all worked fine. But then I thought: Could it be possible to use Select Case structure? So I tried and unfortunately, didn´t run. The uppercase option works as lowercase while the Lowercase and Proper are working as Uppercase. I reviewed the captions that I gave to the buttons and it´s all fine. Could sb help me, please?
Private Sub CancelButton_Click()
Unload UserForm2
End Sub
Private Sub OkButton_Click()
Dim WorkRange As Range
Dim cell As Range
Dim OptionSelect As Variant
On Error Resume Next
Set WorkRange = Selection.SpecialCells(xlCellTypeConstants, xlCellTypeConstants)
Select Case OptionSelect
Case OptionUpper 'Letras Maiúsculas
For Each cell In WorkRange
cell.Value = UCase(cell.Value)
Next cell
Case OptionLower 'Letras Minúsculas
For Each cell In WorkRange
cell.Value = LCase(cell.Value)
Next cell
Case OptionProper 'Iniciais Maiúsculas
For Each cell In WorkRange
cell.Value = Application.WorksheetFunction.Proper(cell.Value)
Next cell
End Select
Unload UserForm2
End Sub
I used another mode to UserForm2:
Sub ChangeCase3()
If TypeName(Selection) = "Range" Then
UserForm2.Show
Else
MsgBox "Selection a range.", vbCritical
End If
End Sub
instead of
Select Case OptionSelect
use
Select Case True
this will give you the proper value to match OptionButtons Values against
The first code takes the value for OptionSelect from somewhere.
If it worked there, then the problem is that in your second code you have this extra line:
Dim OptionSelect As Variant
On this line you make this value empty, so it will make the Select Case useless as there is no value.
Problem:
I have a user-form with a comboBox, textBox and button, the items of comboBox are the cells value in range ((A1:A10) for example).
If I enter a new text in comboBox which isn't in the range, I need to add this value to the range, and write it in the textBox, and if it is already exist I want to write it in textBox directly.
I tried to do it but I didn't succeed.
Can anyone help?
Code:
Private Sub UserForm_Initialize()
'cmbx.RowSource = "d2:d100"
Dim cLoc As Range
Dim ws As Worksheet
Set ws = Worksheets("LookupLists")
For Each cLoc In ws.Range("LocationList")
cmbx.AddItem cLoc.Value
Next cLoc
End Sub
If I have understood you correctly then I guess this is what you are tying to do?
For this, please ensure that in design mode, you set the ComboBoxes's .Style property to 0-fmStyleDropDownCombo. This will ensure that you can type in the combobox. :) I have also commented the code so that you will not have a problem understanding the code. But if you still do then simply post back.
My Assumptions: There is nothing below Cell A10
Code:
Dim ws As Worksheet
Dim cLoc As Range
'~~> Prepare your form
Private Sub UserForm_Initialize()
Set ws = ThisWorkbook.Sheets("LookupLists")
For Each cLoc In ws.Range("LocationList")
cmbx.AddItem cLoc.Value
Next cLoc
End Sub
'~~> This will do what you want
Private Sub cmbx_AfterUpdate()
Dim lRow As Long
'~~> Check if the value is in the range
'~~> If not then add it to the range and textbox as well
If Not IFEXISTS(cmbx.Value) Then
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lRow).Value = cmbx.Value
'~~> Delete the Named range so that we can re-create
'~~> it to include the new value
ThisWorkbook.Names("LocationList").Delete
ThisWorkbook.Names.Add Name:="LocationList", RefersToR1C1:= _
"=LookupLists!R1C1:R" & lRow & "C1"
End If
'~~> Add to textbox
TextBox1.Text = cmbx.Value
End Sub
'~~> function to check if the value is in the textbox or not
Function IFEXISTS(cmbVal As String) As Boolean
For Each cLoc In ws.Range("LocationList")
If UCase(Trim(cLoc.Value)) = UCase(Trim(cmbVal)) Then
IFEXISTS = True
Exit For
End If
Next cLoc
End Function
I have a decent sized worksheet and I want to delete/clear the contents of any empty cells. They don't have a space or any character that I can see (Len() returns a zero) and they're being counted by Counta.
Here's the macro I've developed, it's supposed to clear the contents of each cell in the selection that has a length of zero:
Sub NoNull()
Dim rCell As Range
Dim iLen As Integer
For Each rCell In Selection
iLen = WorksheetFunction.Len(Range(rCell))
If iLen = 0 Then rCell.ClearContents
Next rCell
End Sub
I get an error on this line:
iLen = WorksheetFunction.Len(Range(rCell))
I ASSUME it's related to the way I input the rCell into the Len formula.
You are VERY CLOSE:
Sub NoNull()
Dim rCell As Range
Dim iLen As Integer
For Each rCell In Selection
iLen = Len(rCell)
If iLen = 0 Then rCell.ClearContents
Next rCell
End Sub
If the cells are truly blank then you can do this in a single shot with SpecialCells
If the cells may contain formulae that evaluate to a zero length string then your original loop can be improved by turning off ScreenUpdating and removing the redunandant iLen = Len(rCell))
for tuly empty cells
Sub NoNull()
On Error Resume Next
Selection.SpecialCells(xlBlanks).ClearContents
End Sub
better loop code
Sub NoNull()
Dim rCell As Range
Application.ScreenUpdating = False
For Each rCell In Selection
If Len(rCell.Value) = 0 Then rCell.ClearContents
Next rCell
Application.ScreenUpdating = True
End Sub
I am using the SHEETOFFSET VBA code
Function SHEETOFFSET(offset, Ref)
' Returns cell contents at Ref, in sheet offset
Application.Volatile
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
End With
End Function
And then the following code within within my new sheet
=sheetoffset(-1, B2)
to copy the value of cell B2 in the previous sheet to my new sheet.
However, I also need to copy the color of that particular cell. Is there any code that I can enter in the original VBA code above to do this? Or is there another way of achieving this?
Many thanks for your help
Tim
Logic:
Define a Public variable to hold the color of the cell
In Worksheet_Change check if the above variable has any value. If yes then change the color of the target cell.
Once the above is done, reset the variable to 0
Code in Module:
Public cellColor As Double
Function SHEETOFFSET(offset, Ref)
With Application.Caller.Parent
SHEETOFFSET = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Value
'~~> Store the color in a variable
cellColor = .Parent.Sheets(.Index + offset) _
.Range(Ref.Address).Interior.ColorIndex
End With
End Function
Code in Sheet Code Area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aCell As Range
On Error GoTo Whoa
Application.EnableEvents = False
For Each aCell In Target.Cells
If cellColor <> 0 Then aCell.Interior.ColorIndex = cellColor
Next
Letscontinue:
cellColor = 0
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
ScreenShot:
My Personal Thoughts:
I am not in favor of the SHEETOFFSET function in the first place because the formula is actually referring a cell in the current sheet. Any changes, for example, deletion of that cell will error out your formula
It is better to link the cells directly
FOLLOWUP (From Comments)
You can run this code in the end to refresh all formulas.
Sub Sample()
Dim ws As Worksheet
Dim rng As Range, aCell As Range
For Each ws In ThisWorkbook.Sheets
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
For Each aCell In rng
aCell.Formula = aCell.Formula
Next
End If
Next
End Sub