Excel VBA - Capitalizing all selected cells in a column with formulas - vba

I used the code from Siddharth Rout on the following thread to capitalize selected columns but ran into a Error '13' MISMATCH when I used it on a column with cells that had formulas in some of the range.
Excel VBA - Capitalizing all selected cells in column on double click
Here is the code that worked on non-formula based column data from the above link:
Sub ChangeToUpper()
Dim rng As Range
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
End If
Set rng = Selection
rng = WorksheetFunction.Transpose(Split(UCase(Join( _
WorksheetFunction.Transpose(rng), vbBack)), vbBack))
End Sub
I searched the forums and didn't find specifics related to this. So I googled it and Mr.Excel had this code but still gave the Error '13', when I cleared out of the error message everything was capitalized. Is there a way to eliminate getting this error?
Here is the code from Mr.Excel:
Sub MyUpperCase()
Application.ScreenUpdating = False
Dim cell As Range
For Each cell In Range("$A$1:" & Range("$A$1").SpecialCells(xlLastCell).Address)
If Len(cell) > 0 Then cell = UCase(cell)
Next cell
Application.ScreenUpdating = True
End Sub

Check If Cell has formula and or errors, If yes then ignore.
Sub MyUpperCase()
Application.ScreenUpdating = False
Dim cell As Range
For Each cell In Range("$A$1:" & Range("$A$1").SpecialCells(xlLastCell).Address)
'/ Exclude errors
If Not IsError(cell) Then
If Len(cell) > 0 And Not cell.HasFormula Then
cell = UCase(cell)
End If
End If
Next cell
Application.ScreenUpdating = True
End Sub

Related

Application.Input box to enter range for copy and paste options

I have been trying to copy and paste from one sheet to another, whereby the cells should be copied with the pastelink feature, while making use of the input box to let the user enter the range where he wants to paste the copied data. The code works within the same sheet but not on a different one. Even if it works, it does not recognise the range I have entered in the input box. Instead, it recognises the cursor and pastes whereby the cursor is in the destination worksheet.
This is the code I used for the copying and pasting from sheet 1 to sheet 2. Is there any problem with the codes for which why it does not recognise the range I have entered in the input box?
Sub tryuserinput()
Dim rng As Range
Dim inp As Range
Selection.Interior.ColorIndex = 37
Set inp = Selection
Set rng = Application.InputBox("Copy to", Type:=8)
inp.Copy
rng.Select
Worksheets("Sheet2").Paste Link:=True
End Sub
Is this what you are trying?
Sub Sample()
Dim rng As Range, inp As Range
'~~> Check if what the user selected is a valid range
If TypeName(Selection) <> "Range" Then
MsgBox "Select a range first."
Exit Sub
Else
Set inp = Selection
inp.Interior.ColorIndex = 37
End If
Set rng = Application.InputBox("Copy to", Type:=8)
If Not rng Is Nothing Then
rng.Parent.Activate
rng.Select
inp.Copy
ActiveSheet.Paste Link:=True
End If
End Sub
Revised because...I didn't research. Just use this line of code after you choose the range in other sheet.
inp.Copy Destination:=ThisWorkbook.Sheets("Sheet2").Range(rng.Address)

Get the column of a user selected cell using vba excel

Refer to this question: Let the user click on the cells as their input for an Excel InputBox using VBA.
I use this line of code Set rng = Application.InputBox(Prompt:="Select the cell you want to edit.", Title:="CELL TO EDIT", Type:=8) to ask the user to select a cell. If the cell that is selected is in column G then I will need to call a subroutine. So, I need to figure out what column the selected cell is in.
Thanks for the help!
Use rng.Column property to return column number:
Sub test()
Dim rng As Range
On Error Resume Next
Set rng = Application.InputBox(Prompt:="Select the cell you want to edit.", title:="CELL TO EDIT", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
'column G=7
If rng.Column = 7 Then
'do something
End If
End Sub
If user can select more than one cell, change
If rng.Column = 7 Then
to
If Not Application.Intersect(rng, Sheets("Sheet1").Range("G:G")) Is Nothing Then

SHEETOFFSET to copy color

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

How to delete all row which contains "Grand Total" in Excel automatically?

In my active sheet called Report I have 2 column I & F.
It has repeating cells containing text "Grand Total".
I would like to delete whole row if it contains Grand Total automatically.
VBA code would be nice.
With the following VBA code, you can quickly delete the rows with certain cell value, please do as the following steps:
Select the range that you want to delete the specific row.
Click Developer>Visual Basic, a new Microsoft Visual Basic for applications window will be displayed, click Insert > Module, and input the following code into the Module:
VBA code to Remove entire rows based on cell value(i.e. Grand Total):
Sub Delete_Rows()
Dim rng As Range, cell As Range, del As Range
Set rng = Intersect(Range("A1:D22"), ActiveSheet.UsedRange)
For Each cell In rng
If (cell.Value) = "Grand Total" _
Then
If del Is Nothing Then
Set del = cell
Else: Set del = Union(del, cell)
End If
End If
Next cell
On Error Resume Next
del.EntireRow.Delete
End Sub
Then click "Play/Run" button to run the code, and the rows which have certain value have been removed.
(Note: If you can't see Developer Tab in Excel Do these Steps: 1)Click the Office Button, and then click Excel Options. 2)In the Popular category, under Top options for working with Excel, select the Show Developer tab in the Ribbon check box, and then click OK.)
Using AutoFilter is very efficient. This can also be done without VBA (ie manually)
Main Sub
Sub Main()
Dim ws As Worksheet
Dim rng1 As Range
Dim StrIn As String
Dim rng2 As Range
Set ws = Sheets("Sheet1")
Application.ScreenUpdating = False
Set rng1 = ws.Range("F:F,I:I")
StrIn = "Grand Total"
For Each rng2 In rng1.Columns
Call FilterCull(rng2, StrIn)
Next
Application.ScreenUpdating = True
End Sub
Delete Sub
Sub FilterCull(ByVal rng2, ByVal StrIn)
With rng2
.Parent.AutoFilterMode = False
.AutoFilter Field:=1, Criteria1:=StrIn
.EntireRow.Delete
.Parent.AutoFilterMode = False
End With
End Sub
This should help get you started.
http://msdn.microsoft.com/en-us/library/office/ee814737%28v=office.14%29.aspx#odc_Office14_ta_GettingStartedWithVBAInExcel2010_VBAProgramming101
Also see similar question:
Delete a row in Excel VBA

Prevent user from deleting certain rows based on contents of a cell in that row

I have a template file that I want to protect so that users cannot modify formulas. As the sheet is protected, I have written a macro to allow the user to insert rows. I also want a macro to allow the user to delete rows, but I want to prevent the user from deleting certain critical rows (e.g. check totals and headings, etc.).
To this end I have used column L in my template to identify rows that cannot be deleted. For these rows I have the word "keep" in that row of column L. I have written a basic delete macro below but I need to modify it to look in column L of the selected range rRange and Exit Sub if the word "keep" is there.
*Note that rRange could contain a number of adjacent rows so the macro would need to exit if any of those rows fail the test.
Sub DeteteRows()
Dim rRange As Range
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please use mouse to select a row to Delete.", _
Title:="SPECIFY ROW TO DELETE", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
Else
rRange.EntireRow.Delete
Range("a1").Select
MsgBox ("Row(s) Deteted")
End If
End Sub
This may not be the best way but it is below. I did not add the delete portion in the last if then else as I figured you can handle that
Sub DeteteRows()
Dim rRange As Range
Dim bKeepFound As Boolean
bKeepFound = False
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please use mouse to select a row to Delete.", _
Title:="SPECIFY ROW TO DELETE", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange Is Nothing Then
Exit Sub
'dont need the else statement cause you exit the sub if it fails
End If
For Each Row In rRange.Rows
Dim s 'variable to hold the array
s = Split(Row.Address, ":") 'split out the column and row
'remove the $ and convert to a number then check the cell value
If rRange.Cells(CInt(Replace(s(0), "$", "")), 12).Value = "keep" Then
bKeepFound = True
End If
Next Row
'check to see if a row was found to keep
If bKeepFound Then
Exit Sub 'row was found so exit sub
Else
'delete the rows in the range
End If
End Sub