I wanted to write a function that detects if there is an Image in the cell. When not, it goes to the next row. The column stays the same.
My Function doesnt work.
Public Function HasImage(ByVal Target As Range) As Boolean
Dim bResult As Boolean
Dim shp As Shape
bResult = False
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address _
And shp.BottomRightCell.Address = Target.Address Then
bResult = True
End If
Next shp
HasImage = bResult
End Function
I may be wrong but does your BottomRightCell have to be offset (1,1) from the topleft when image sized to one cell?
In my testing your code seemed to fail because of the BottomRightCell.Address, with pic sized to one cell, being a row below and a column to the right.
I tested with the following code where I adjusted BottomRightCell.Address with:
And shp.BottomRightCell.Address = Target.Offset(1, 1).Address
Code:
Option Explicit
Public Sub test()
Dim mypic As Object
Set mypic = ActiveSheet.Pictures(1)
PositionPic mypic
MsgBox HasImage([A1])
MsgBox mypic.BottomRightCell.Address
End Sub
Public Function HasImage(ByVal Target As Range) As Boolean
Dim bResult As Boolean
Dim shp As Shape
bResult = False
For Each shp In ActiveSheet.Shapes
If shp.TopLeftCell.Address = Target.Address _
And shp.BottomRightCell.Address = Target.Offset(1, 1).Address Then
bResult = True
End If
Next shp
HasImage = bResult
End Function
Public Sub PositionPic(ByVal mypic As Object)
With mypic
.Left = ActiveSheet.Cells(1, 1).Left
.Top = ActiveSheet.Cells(1, 1).Top
.Width = ActiveSheet.Cells(1, 1).Width
.Height = ActiveSheet.Cells(1, 1).Height
End With
End Sub
Related
I am trying to achieve code where multi-select ListBoxes are added if Column 4 or 5 are selected and Column 2 in the same row has the string "has options".
The Listboxes contain values from named ranges called "option1" and "option2". Current Selections are output to the respective cell in Column 4 or 5 separated by commas.
This is the code I have in "This Workbook" object. It needs to work on all sheets.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 4 And Target.OFFSET(0, -1).Value = "has options" Then
CreateOpt1PopUp Target
End If
If Target.Column = 5 And Target.OFFSET(0, -2).Value = "has options" Then
CreateOpt2PopUp Target
End If
Else
DeleteAllOpt1PopUps Target
DeleteAllOpt2PopUps Target
End If
End If
End Sub
This is the code I have in a Module. The criteria has evolved and therefore I have amended the code multiple times to the point where it no longer works.
Private opt1SelectCell As Range
Public Function Opt1Area(ByRef ws As Worksheet) As Range
Const OPT1_COL As Long = 4
Dim lastOpt1Row As Long
With ws
lastOpt1Row = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
If lastOpt1Row = 0 Then
Set Opt1Area = Nothing
Else
Set Opt1Area = .Cells(2, OPT1_COL).Resize(lastOpt1Row, 1)
End If
End With
End Function
Public Sub Opt1BoxClick()
Dim opt1BoxName As String
opt1BoxName = Application.Caller
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes(opt1BoxName)
Dim opt1List As String
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.Selected(i) Then
opt1List = opt1List & opt1Box.List(i) & ","
End If
Next i
If Len(opt1List) > 0 Then
opt1List = Left$(opt1List, Len(opt1List) - 1)
End If
opt1SelectCell.Value = opt1List
End Sub
Public Function Opt1ListArea() As Range
Set Opt1ListArea = ActiveSheet.Range("option1")
End Function
Public Sub DeleteAllOpt1PopUps(ByRef selectedCell As Range)
Dim opt1Box As ListBox
For Each opt1Box In selectedCell.Parent.ListBoxes
opt1Box.Delete
Next opt1Box
End Sub
Public Sub CreateOpt1PopUp(ByRef selectedCell As Range)
Set opt1SelectCell = selectedCell
Dim Opt1PopUpCell As Range
Set Opt1PopUpCell = opt1SelectCell.OFFSET(1, 0)
DeleteAllOpt1PopUps selectedCell
'--- now create listbox
Const OPT1_POPUP_WIDTH As Double = 75
Const OPT1_POPUP_HEIGHT As Double = 110
Const OPT1_OFFSET As Double = 5#
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes.Add(Opt1PopUpCell.Left + OPT1_OFFSET, _
Opt1PopUpCell.Top + OPT1_OFFSET, _
OPT1_POPUP_WIDTH, _
OPT1_POPUP_HEIGHT)
With opt1Box
.ListFillRange = Opt1ListArea().Address(external:=True)
.LinkedCell = ""
.MultiSelect = xlSimple
.Display3DShading = True
.OnAction = "Module1.Opt1BoxClick"
End With
'--- is there an existing list of options selected?
Dim selectedOptions1() As String
selectedOptions1 = Split(opt1SelectCell.Value, ",")
Dim opt1 As Variant
For Each opt1 In selectedOptions1
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.List(i) = opt1 Then
opt1Box.Selected(i) = True
Exit For
End If
Next i
Next opt1
End Sub
This is an example of the excel data.
How can I make this work and even improve it?
I have added a Date Picker to an Excel table with the Private Sub below. When I select a row or column I get a Run-Time Error 1004. When I select Debug the line below is highlighed as the error:
.Left = Target.Offset(0, 1).Left
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Sheet1.DTPicker1
.Height = 20
.Width = 20
If Not Intersect(Target, Range("A7:B135,J7:J135")) Is Nothing Then
.Visible = True
.Top = Target.Top
.Left = Target.Offset(0, 1).Left
.LinkedCell = Target.Address
Else
.Visible = False
End If
End With
End Sub
Many thanks in advance for any assisstance
Nick
It's best to use Intersect to create a new range and use that in place of Target
Something like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rng As Range
With Sheet1.DTPicker1
.Height = 20
.Width = 20
Set rng = Intersect(Target, Me.Range("A7:B135,J7:J135"))
if rng Is Nothing then
.Visible = False
Else
if rng.cells.count > 1 Then
.Visible = False
else
.Visible = True
.Top = rng.Top
.Left = rng.Offset(0, 1).Left
.LinkedCell = rng.Address
End if
End If
End With
End Sub
I'd like to write a VBA code that checks if a cell has an image and if it does print something (could be anything, in this case I chose a number 1) in the same row as the image, in column #6.
I keep getting the "Argument not Optional" Error on the first line of the sub. Curious if someone can help me! Thank you!!
Function CellImageCheck(CellToCheck As Range) As Integer
' Return 1 if image exists in cell, 0 if not
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell = CellToCheck Then
CellImageCheck = 1
Else
CellImageCheck = 0
End If
Next wShape
End Function
Sub testFunction()
Dim i As Integer
Application.ScreenUpdating = False
For i = 3 To 10 Step 1
If CellImageCheck(Cells(i, 1)) Then
Cells(i, 6) = CellImageCheck
Else
End If
Next i
End Sub
As per my comment:
Function CellImageCheck(CellToCheck As Range) As Boolean
' Return True if image exists in cell, False if not
CellImageCheck = False
Dim wShape As Shape
For Each wShape In ActiveSheet.Shapes
If wShape.TopLeftCell.Address = CellToCheck.Address Then
CellImageCheck = True
Exit For
End If
Next wShape
End Function
Sub testFunction()
Application.ScreenUpdating = False
With Worksheets("Sheet1") 'Change this to the sheet being tested.
Dim i As Long
For i = 3 To 10 Step 1
Dim bl As Boolean
bl = False
bl = CellImageCheck(.Cells(i, 1))
If bl Then .Cells(i, 6) = bl
Next i
End With
End Sub
This function loops through all the textboxes in the workbook to find and highlight text + textbox that contain the result.
The problem is: if I trigger it from a specific sheet, all the textboxes in that sheet that contain the result will NOT be highlighted (text is found though, so it works halfway).
If I trigger it from a worksheet that does not contain a textbox with a result, then everything works.
Dim shp As Shape
Dim Color As String
Dim ColorIndexobj As String
Dim Sizeobj As Integer
Dim sFind As String
Dim sFind2 As String
Dim sTemp As String
Dim iPos As Integer
Dim sTemp2 As String
Dim iPos2 As Integer
Dim Response
Dim sourceSheet As Worksheet
Set sourceSheet = ActiveSheet
sFind = InputBox("Search for?")
If Trim(sFind) = "" Then
MsgBox "Nothing entered"
Exit Sub
End If
For Each ws In ActiveWorkbook.Worksheets
ws.Select
For Each shp In ws.Shapes
If shp.Type = msoTextBox Then
sTemp = shp.TextFrame.Characters.Text
If InStr(LCase(sTemp), LCase(sFind)) <> 0 Then
shp.Select
With shp.Line
Color = shp.Line.ForeColor.RGB
Weight = shp.Line.Weight
.ForeColor.RGB = vbRed
.Weight = 5
End With
sFind2 = LCase(sFind)
sTemp2 = LCase(shp.TextFrame.Characters.Text)
iPos2 = InStr(sTemp2, sFind2)
If iPos2 > 0 Then
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
Sizeobj = .Size
.Size = 35
End With
End If
Set sourceSheet = ActiveSheet
Response = MsgBox( _
"Do you want to continue?", _
Buttons:=vbYesNo, Title:="Continue?")
If Response = vbYes Then
With shp.Line
.ForeColor.RGB = Color
.Weight = Weight
End With
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
.Size = Sizeobj
End With
End If
If Response = vbNo Then
With shp.Line
.ForeColor.RGB = Color
.Weight = Weight
End With
With shp.TextFrame.Characters(Start:=iPos2, _
Length:=Len(sFind2)).Font
.Size = Sizeobj
End With
Exit Sub
End If
End If
End If
Next
Next
Call sourceSheet.Activate
End Sub
The problem is that the change that you are doing is undone before the window is ever repainted.
Here is a kludge (from this answer):
Immediately after
With shp.Line
Color = shp.Line.ForeColor.RGB
Weight = shp.Line.weight
.ForeColor.RGB = vbRed
.weight = 5
End With
Put the line:
ActiveWindow.SmallScroll 0
Exactly what causes a window to repaint during a running macro isn't clearly documented. The rules are evidently different as they apply to the active sheet, which would explain the behavior that you are observing. There isn't any simple RePaint method of a worksheet, hence the kludge, which works since scrolling triggers a repaint, even if the distance scrolled is zero.
From some reason, using DoEvents rather than this kludge doesn't seem to work.
I'm using VB code created by L42 on 4/27/14 that creates a checkbox list in a single cell.
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj=Me.OLEObjects("LB_Colors")
Set LBColors = Target
If Not Intersect(Target, [B2]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount -1
If fillRng.Value = Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & "," & .List(i)
End If
Next
End With
Set fillRng = Nothing
End If
End If
End Sub
The code works perfectly and I was able to extend the checkbox list to the cells in complete column by changing the (Target, [B1:B40]). Following this logic, I thought that I could extend checkboxes C and D columns by (Target, [B1:D40]. However, after selecting desired items in B column and clicking or tabing over to C column, the entire checkbox moves with selected items without writing in the previous cell. I would like to be able to tab over or click to the next cell in the row and have same checkbox items that populates that cell with item selected, independent of the previous cell. Then tab or click to succeeding cells and do the same and have cells retain and display selected the items. Can this code be modified to do that?
Thank you.
to always put the values in the cell, just change your code to something like this:
Option Explicit
Dim fillRng As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBobj As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Colors")
Set LBColors = Target
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If .Selected(i) Then
If fillRng.Value = "" Then
fillRng.Value = .List(i)
Else
fillRng.Value = fillRng.Value & "," & .List(i)
End If
End If
Next
End If
End With
Set fillRng = Nothing
End If
If Not Intersect(Target, [B1:D40]) Is Nothing Then
Set fillRng = Target
With LBobj
.Left = fillRng.Left
.Top = fillRng.Top
.Width = fillRng.Width
.Visible = True
End With
End If
End Sub