Currently I managed to do for a single cell when the specified cell is empty then message / statement display on the cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("AA17").Value = ISBLANK Then
Range("AA17").Value = "Please Specify"
End If
End Sub
What I would like to do is, for a several cell it will display the same thing. I can go ahead and do the same as above for all celsl but I have a few hundred cell to format it that way.
Is there a way to do so?
If the cells are contiguous, you could loop through them.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim checkRng As Range
Dim cel As Range
Set checkRng = Range("A7:A70")
For Each cel In checkRng
If cel.Value = ISBLANK Then
cel.Value = "Please Specify"
End If
Next cel
End Sub
if there is any changes within the specified Range, the below code will run
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set Rng = ws.Range("A1:A100")
If Not Intersect(Target, Rng) Is Nothing Then
For Each Cell In Rng
If IsEmpty(Cell.Value) = True Then
Cell.Value = "Please Specify"
End If
Next
End If
Set Rng = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
Related
I am trying to embed applying a chart template into a macro and require help.
I have this code for the Macro that I am using to create scatter plots:
Option Explicit
Public Sub Test()
' Keyboard Shortcut: Ctrl+Shift+X
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1") 'change as appropriate
Application.ScreenUpdating = False
BuildChart ws, SelectRanges(ws)
Application.ScreenUpdating = True
End Sub
Private Function SelectRanges(ByRef ws As Worksheet) As Range
Dim rngX As Range
Dim rngY As Range
ws.Activate
Application.DisplayAlerts = False
On Error Resume Next
Set rngX = Application.InputBox("Please select X values. One column.",
Type:=8)
If rngX Is Nothing Then GoTo InvalidSelection
Set rngY = Application.InputBox("Please select Y values. One column.",
Type:=8)
If rngY Is Nothing Then GoTo InvalidSelection
If rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then GoTo
InvalidSelection
On Error GoTo 0
Set SelectRanges = Union(rngX, rngY)
Application.DisplayAlerts = True
Exit Function
InvalidSelection:
If rngX Is Nothing Or rngY Is Nothing Then
MsgBox "Please ensure you have selected both X and Y ranges."
ElseIf rngX.Rows.Count <> rngX.Rows.Count Then
MsgBox "Please ensure the same number of rows are selected for X and Y
ranges"
ElseIf rngX.Columns.Count > 1 Or rngY.Columns.Count > 1 Then
MsgBox "Please ensure X range has only one column and Y range has only
one column"
Else
MsgBox "Unspecified"
End If
Application.DisplayAlerts = True
End
End Function
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
End With
ActiveChart.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End Sub
And would like to embed this code below into the above code so that it applies the template to the chart I create whenever I run this Macro. My initial guess would be to put it underneath "Private Sub BuildCharts". How would I be able to do this? Thank you.
ActiveChart.ApplyChartTemplate ( _
"C:\Users\XXXXX\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
Perhaps modify Sub BuildChart like this:
Private Sub BuildChart(ByRef ws As Worksheet, ByRef unionRng As Range)
With ws.Shapes.AddChart2(240, xlXYScatter).Chart
.SetSourceData Source:=unionRng
.ApplyChartTemplate ( _
"C:\Users\maaro\AppData\Roaming\Microsoft\Templates\Charts\1.crtx")
End With
End Sub
Can someone please point out what's wrong with this snippet of code? Every time a value is changed in the specified range (A1:B6), Excel simply quits with Microsoft Error Reporting dialogue. I am not allowed to uncheck 'Error Checking (Turn on background error checking)' in Excel Preferences.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A1:B6")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Call Macro1
MsgBox "Test"
End If
End Sub
Macro1:
Sub Macro1()
Dim wb As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rInterestCell As Range
Dim rDest As Range
Set wb = ActiveWorkbook
Set wsData = wb.Sheets("Sheet1")
Set wsDest = wb.Sheets("Formula Results")
For Each rInterestCell In Range("Interest_Range").Cells
wsData.Range("A7").Value = rInterestCell.Value
wsData.Calculate
Set rDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
If rDest.Row < 6 Then Set rDest = wsDest.Range("A6")
rDest.Value = wsData.Range("A6").Value
Next rInterestCell
End Sub
Second Macro
Sub Macro2()
Dim FLrange As Range
Set FLrange = Range(“Initial_Rate”)
For Each cell In FLrange
cell.Offset(0, 5).Formula = "=SUM(B3/100*A7)”
Next cell
End Sub
You'd better turn off events with Application.EnableEvents = False before doing so much calculation in Macro1.
If this works, just comment MsgBox "Before Macro1" and MsgBox "After Macro1"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Me.Range("A1:B6")
If Not Application.Intersect(KeyCells, Target) Is Nothing Then
MsgBox "Before Macro1"
Macro1
MsgBox "After Macro1"
End If
End Sub
Macro1:
Sub Macro1()
Dim wB As Workbook
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rInterestCell As Range
Dim rDest As Range
Set wB = ActiveWorkbook
Set wsData = wB.Sheets("Sheet1")
Set wsDest = wB.Sheets("Formula Results")
Application.EnableEvents = False
For Each rInterestCell In Range("Interest_Range").Cells
wsData.Range("A7").Value = rInterestCell.Value
wsData.Calculate
DoEvents
Set rDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
If rDest.Row < 6 Then Set rDest = wsDest.Range("A6")
rDest.Value = wsData.Range("A6").Value
Next rInterestCell
Application.EnableEvents = True
End Sub
I have a excel sheet having check boxes from Range "D12" to "D26", on click of abutton I want to select all checkboxes but based on only range i.e. all checkboxes in Range("D12:D26").
Code which I am using is below, but not working for me:
Private Sub SelectALL_Click()
Dim cells As Range
Dim rng As Range
Set rng = Sheet1.Range("D12:D14")
For Each cells In rng
cells.Select
Next
End Sub
Since you have not mentioned what kind of control is it (ActiveX or Form Control), take your pick
Form Control Example
Sub FormControl_Example()
Dim shp As Shape
Dim rng As Range, rngShp As Range
With ThisWorkbook.Sheets("Sheet1") '<~~ Change this to the relevant sheet name
Set rng = .Range("D12:D14")
For Each shp In .Shapes
Set rngShp = .Range(shp.TopLeftCell.Address)
If Not Intersect(rngShp, rng) Is Nothing Then
shp.OLEFormat.Object.Value = True
End If
Next
End With
End Sub
ActiveX Control Example
Sub ActiveX_Example()
Dim shp As Shape
Dim rng As Range, rngShp As Range
With ThisWorkbook.Sheets("Sheet1") '<~~ Change this to the relevant sheetname
Set rng = .Range("D12:D14")
For Each shp In .Shapes
Set rngShp = .Range(shp.TopLeftCell.Address)
If Not Intersect(rngShp, rng) Is Nothing Then
.OLEObjects(shp.Name).Object.Value = True
End If
Next
End With
End Sub
I'm a newbie at vba so please excuse my ignorance. I created a macro that will run through a dropdown list and print for each name in the dropdown - and it works:
Sub PrintAll()
Dim Cell As Range
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("PRINT PAGE")
Set Rng = ThisWorkbook.Names("Brokers").RefersToRange
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
However, the workbook has multiple worksheets to read from and therefore I need the vba to read from multiple ranges so I tried this
Sub PrintAll()
Dim Cell As Range
Dim Cell2 As Range
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("PRINT PAGE")
If "$A$5" = "Company1" Then Rng = ThisWorkbook.Names("1Brokers").RefersToRange
ElseIf "$A$5" = "Company2" Then Rng = ThisWorkbook.Names("2Brokers").RefersToRange
Else: Set Rng = ThisWorkbook.Names("3Brokers").RefersToRange
End If
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
The problem is I keep getting "Compile error Else without If" on the If statement. Is there something wrong with how I'm setting up the If statement or with how I'm using it in the code?
This block compiles for me. Please test it. I have always start set in the after then in if.
Sub PrintAll()
Dim Cell As Range
Dim Cell2 As Range
Dim Rng As Range
Dim Wks As Worksheet
'Set Wks = Worksheets("PRINT PAGE")
If "$A$5" = "Company1" Then
Rng = ThisWorkbook.Names("1Brokers").RefersToRange
ElseIf "$A$5" = "Company2" Then
Rng = ThisWorkbook.Names("2Brokers").RefersToRange
Else
Set Rng = ThisWorkbook.Names("3Brokers").RefersToRange
End If
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
Use
If Range("$A$5").Value = "Company1"..
Similarly for "$A$5".
"$A$5" is just a string and you are comparing a string to a string. What you want is a range object
EDIT
Regarding the Error that you are getting, you have to use Then
The syntax is (Hiten004 post made me realize it)
If <Cond> Then
ElseIF <Cond> Then
End If
Rather than:
If "$A$5" = "Company1" Then Rng = ThisWorkbook.Names("1Brokers").RefersToRange
use:
If "$A$5" = "Company1" Then Set Rng = ThisWorkbook.Names("1Brokers").RefersToRange
There may be other problems in your code.
I have the following function using Excel 2010:
Private Function MakeAllSheetsValuesOnly(targetBookName As String)
If Excel.ActiveWorkbook.Name = Excel.ThisWorkbook.Name Then
Else
Excel.Workbooks(targetBookName).Activate
Dim mySheet
For Each mySheet In Excel.ActiveWorkbook.Sheets
With mySheet
With .Cells
.Copy
.PasteSpecial Excel.xlPasteValues
End With
.Select
.Range("A1").Select
End With
Excel.ActiveWindow.SmallScroll Down:=-200
Excel.Application.CutCopyMode = False
Next mySheet
End If
End Function 'MakeAllSheetsValuesOnly
It works but I'd rather not rely on the clipboard is there an alternative way to make all sheets values only?
Just found an alternative logic I've been using in another program which is relevent to this topic:
Dim rSource As Range
Dim rDest As Range
Set rSource = .Range("C5:BG" & .Range("B4").Value + 4)
Set rDest = mySummaryBook.Sheets("Data_Measures").Cells(Rows.Count, 4).End(xlUp)(2, 1)
With rSource
Set rDest = rDest.Resize(.Rows.Count, .Columns.Count)
End With
rDest.Value = rSource.Value
Set rSource = Nothing
Set rDest = Nothing
Maybe something like this:
With mySheet.UsedRange
.Value = .Value
End With
You don't need a function for this.
Tim has already given you a great method. Here is another way...
Sub Sample()
MakeAllSheetsValuesOnly "Book2"
End Sub
Private Sub MakeAllSheetsValuesOnly(targetBookName As String)
Dim mySheet As Worksheet
Dim formulaCell As Range
Dim aCell As Range
Application.ScreenUpdating = False
For Each mySheet In Workbooks(targetBookName).Sheets
On Error Resume Next
Set formulaCell = mySheet.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not formulaCell Is Nothing Then
For Each aCell In formulaCell
aCell.Value = aCell.Value
Next
End If
Next mySheet
Application.ScreenUpdating = True
End Sub
Building on Tim's answer above, which seems to be the most efficient way to do it, you could clean up your code to make it a little faster, less resource intensive. See below. Not huge changes, but will help with processing none-the-less. First don't need Function. Sub will do. No need to select and activate so many things:
Private Sub MakeAllSheetsValuesOnly(targetBookName As String)
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
Dim wkb As Workbook
Set wkb = Workbooks(targetBookName)
With wkb
Dim mySheet As Worksheet
For Each mySheet In wkb.Worksheets
mySheet.UsedRange.Value = mySheet.UsedRange.Value
Next mySheet
End With
End If
End Sub 'MakeAllSheetsValuesOnly