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
Related
I have a seemingly simple goal to turn the content of column B into comments of column A.
I have tried using the following code from #Dy.Lee mentioned here, but unfortunately it gives me a Run-time error '1004' Application-defined or object-defined error...
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
Set rngDB = Range("B1:B50")
For Each rng In rngComent
i = i + 1
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
.Text Text:=rngDB(i).value
End With
Next rng
End Sub
Can somebody, please, spot the mistake or suggest a better solution for this?
I'd go this way (explanations in comments):
Public Sub Komentari()
Dim rng As Range
With Range("A1:A50") ' reference comments range
.ClearComments ' clear its comments
For Each rng In .Offset(, 1).SpecialCells(xlCellTypeConstants) ' loop through refrenced range adjacent not empty cells
With rng.Offset(, -1).AddComment ' add comment to current rng corresponding comment range cell
.Visible = False
.Text rng.Value2
End With
Next
End With
End Sub
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
For Each rng In rngComent
i = i + 1
If Not rng.Range("B1").Comment Is Nothing Then
rng.Range("B1").Comment.Delete
End If
rng.Range("B1").AddComment (rng.Text)
Next rng
End Sub
Something like the following where you can use Offset to get the adjacent range, you drop the = when adding the text value to the comment, test that there is actually a value present first as well, and ensure you state the sheet to avoid implicit Activesheet reference.
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
If rng.Offset(, 1) <> vbNullString Then .Text rng.Offset(0, 1).Value
End With
Next
End With
End Sub
Rather than add blank comments you could also flip this round to:
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
If rng.Offset(, 1) <> vbNullString Then
Set cm = rng.AddComment
With cm
.Visible = False
.Text rng.Offset(0, 1).Value
End With
End If
Next
End With
End Sub
Attempting a macro that will set all selected sheets to have same cells visible as in the active sheet.
Example: if top-left cell is L76 on active sheet, then running this macro will set all selected worksheets to show L76 as the top left cell.
Cobbled this code together from examples found online but not sufficiently advanced in VBA to make it work.
Sub SetAllSelectedSheetsToSameRowColCell()
Dim rngSel As Range
Dim intScrollCol As Integer
Dim intScrollRow As Long
Dim oSheet As Object
If TypeName(Sh) = "Worksheet" Then
Set oSheet = ActiveSheet
Application.EnableEvents = False 'Unsure what this line is for
Sh.Activate
With ActiveWindow
intScrollCol = .ScrollColumn
intScrollRow = .ScrollRow
Set rngSel = .RangeSelection
End With
oSheet.Activate
Application.EnableEvents = True
End If
'Loop thru rest of selected sheets and update to have same cells visible
Dim oWs As Worksheet
For Each oWs In Application.ActiveWindow.SelectedSheets
On Error Resume Next
oWs.Range(rngSel.Address).Select
.ScrollColumn = intScrollCol
.ScrollRow = intScrollRow
Next
End Sub
References:
https://excel.tips.net/T003860_Viewing_Same_Cells_on_Different_Worksheets.html
VBA Macro To Select Same Cell on all Worksheets
Try this:
Sub ResetAllSheetPerspectives()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim dZoom As Double
lRow = ActiveWindow.ScrollRow
lCol = ActiveWindow.ScrollColumn
dZoom = ActiveWindow.Zoom
For Each ws In Application.ActiveWindow.SelectedSheets
ws.Activate
ActiveWindow.Zoom = dZoom
Application.Goto ws.Cells(lRow, lCol), True
Next ws
End Sub
Maybe this will help. Sets the top left cell of other sheets depending on the first sheet.
Sub Macro1()
Dim r As Range, ws As Worksheet
Sheets(1).Activate
Set r = ActiveWindow.VisibleRange.Cells(1)
For Each ws In Worksheets
If ws.Index > 1 Then
ws.Activate
ActiveWindow.ScrollRow = r.Row
ActiveWindow.ScrollColumn = r.Column
End If
Next ws
End Sub
This procedure sets the same visible range as the active worksheet for all selected worksheets. It excludes any Chart sheet in the selection and adjusts the zoom of the selected sheets to ensure all worksheets have the same visible area.
Sub SelectedWorksheets_ToSameVisibleRange()
Dim ws As Worksheet
Dim oShs As Object, oSh As Object
Dim sRgAddrs As String
On Error Resume Next
Set ws = ActiveSheet
On Error GoTo 0
If ws Is Nothing Then
MsgBox "Active sheet must be a worksheet type" & String(2, vbLf) _
& String(2, vbTab) & "Process will be cancelled.", _
vbCritical, "Worksheets Common Range View"
Exit Sub
End If
With ActiveWindow
Set oShs = .SelectedSheets
sRgAddrs = .VisibleRange.Address 'Get address of Active Sheet visible range
End With
For Each oSh In oShs
If TypeName(oSh) = "Worksheet" And oSh.Name <> ws.Name Then 'Excludes any chart sheet and the active sheet
With oSh.Range(sRgAddrs)
Application.Goto .Cells, 1 'Activate Worksheet targeted visible range
ActiveWindow.Zoom = True 'Zoom Worksheet to make visible same range as the "active worksheet"
Application.Goto .Cells(1), 1 'Activate 1st cell of the visible range
End With: End If: Next
ws.Select 'Ungroups selected sheets
End Sub
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
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
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.