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
Related
I am trying to create a macro that inserts an image into one cell when the user enters specific information into an other cell. Right now it's working but not right away. The user has to change the cell then click off of it and then back on. Here is my macro:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
Dim myPict As Picture
Dim ws As Worksheet
ActiveCell.NumberFormat = "#"
Dim curcell As Range
Set curcell = ActiveWindow.ActiveCell.Offset(-3, 0)
Dim PictureLoc As String
PictureLoc = "C:\Users\WPeter\Desktop\VBA_TEST\test\" & ActiveCell.Text & ".jpeg"
If Not Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Address = curcell.Address Then sh.Delete
Next
With ActiveCell.Offset(-3, 0)
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.insert(PictureLoc)
myPict.Height = 119
myPict.Width = 119
myPict.Top = .Top + .Height / 2 - myPict.Height / 2
myPict.Left = .Left + .Width / 2 - myPict.Width / 2
myPict.Placement = xlMoveAndSize
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
End If
End Sub
Any help would be appreciated. Thanks so much!
Untested but this should give you a rough idea of how it could work:
Private Sub Worksheet_Change(ByVal Target As Range)
Const FLDR = "C:\Users\WPeter\Desktop\VBA_TEST\test\"
Dim KeyCells As Range, myPict As Picture, cPic As Range
Dim c As Range, rng As Range, PictureLoc As String
Set KeyCells = Range("b7:f7,b13:f13,b19:f19,b25:f25,b31:f31,b37:f37")
Set rng = Application.Intersect(Target, KeyCells)
If rng Is Nothing Then Exit Sub
RemovePics rng.Offset(-3, 0) 'remove any existing shapes for this range
For Each c In rng.Cells 'check each chsnged cell in the monitored range
c.Font.Color = vbRed
c.NumberFormat = "#"
PictureLoc = FLDR & c.text & ".jpeg"
If Len(Dir(PictureLoc)) > 0 Then 'does the file exist?
Set cPic = c.Offset(-3, 0) 'picture destination cell
With Me.Pictures.Insert(PictureLoc)
.Height = 119
.Width = 119
.Top = cPic.Top + cPic.Height / 2 - .Height / 2
.Left = cPic.Left + cPic.Width / 2 - .Width / 2
.Placement = xlMoveAndSize
End With
c.Font.Color = vbBlack
Else
c.Font.Color = vbRed 'flag file not found (or use msgbox)
End If
Next c
End Sub
'remove any shape whose topleftcell intersects with range `rng`
Sub RemovePics(rng As Range)
Dim i As Long
For i = Me.Shapes.Count To 1 Step -1 'step backwards if deleting
With Me.Shapes(i)
If Not Application.Intersect(.TopLeftCell, rng) Is Nothing Then .Delete
End With
Next i
End Sub
Thank you all for your help. There seemed to be a list of things I was doing g incorrectly (Including using Target instead of ActiveCell) but I finally got it to work. This is my current code
Function IsFile(ByVal fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("b7:e7,b13:e13,b19:e19,b25:e25,b31:e31,b37:e37")
Dim PictureLoc As String
Dim myPict As Picture
Dim ws As Worksheet
Target.NumberFormat = "#"
Dim imgcell As Range
Set imgcell = Target.Offset(-3, 0)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
For Each sh In ActiveSheet.Shapes
If sh.TopLeftCell.Address = imgcell.Address Then sh.Delete
Next
If IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpeg"
ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".jpg"
ElseIf IsFile("\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png") = True Then
PictureLoc = "\\amer.turck.info\data\Plymouth\Marketing\Asim Connectivity Image Project\Vending_poster\images\" & Target.Text & ".png"
End If
With imgcell
On Error GoTo errormessage:
Set myPict = ActiveSheet.Pictures.Insert(PictureLoc)
myPict.Height = 119
myPict.Width = 119
If myPict.Height > 119 Then
myPict.Height = 119
End If
myPict.Top = .Top + .Height / 2 - myPict.Height / 2
myPict.Left = .Left + .Width / 2 - myPict.Width / 2
myPict.Placement = xlMoveAndSize
errormessage:
If Err.Number = 1004 Then
MsgBox "File does not Exist, Please first update photo with .jpg File"
End If
End With
End If
End Sub
Also I apologize if this request was messy or disorganized. It is my first time posting on Stackoverflow/
I have a table that contains the file path, when the button is clicked the macro will display an image according to the url path. Here is my code (sourch : Link)
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5:D6, G5:H6, C8:D9, G8:H9")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = Cells(cell.Row, cColumn)
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
The code works as shown in the following illustration.
But I want the image to be in all merged cells. As shown in the following picture
Please let me know if you see anything that will fix this! I'm sure it's something simple, but I've been stuck for a while on this one.
You can use the MergeArea property of the Range object to return the merged range. Your macro can amended as follows (untested) . . .
Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5, G5, C8, G8")
For Each cell In xRange
cName = cell
ActiveSheet.Pictures.Insert(cName).Select
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column
Set cRange = cell.MergeArea
With cShape
.LockAspectRatio = msoFalse
.Height = cRange.Height - 5
.Width = cRange.Width - 5
.Top = cRange.Top + 2
.Left = cRange.Left + 2
.Placement = xlMoveAndSize
End With
line22:
Set cShape = Nothing
Next
Application.ScreenUpdating = True
End Sub
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
I have a userform with a textbox and a listbox with the following plan:
Users input text in Textbox1.
Every time Textbox1.Text changes, a search with the following features is performed:
Textbox1.Text is searched in a specific range in a worksheet.
Textbox1.Text can be found more than once.
Listbox1 is populated with the results of the search.
So far so good. Due to having large set of data, the list can get many items. In this case the list reaches out of the screen and I had to limit Listbox1.Height. This is the code for the above:
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
If TextBox1.Value = "" Then
ListBox1.Height = 0
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A2:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then
.AddItem (cell.Value)
Select Case .ListCount
Case Is < 2
.Height = 17
Case Is < 21
.Height = 15 * .ListCount
Case Else
.Height = 272.5
End Select
Me.Height = 500
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
End If
End With
End If
End Sub
The problem was in Case Else when scroll was enabled I couldn't reach the last item of the list. By searching on the net I found some potential solutions:
set Listbox1.IntegralHeight = False set the height and then set again Listbox1.IntegralHeight = True
set Listbox1.MultiSelect = fmMultiSelectSingle and then set again Listbox1.MultiSelect = fmMultiSelectExtended.
do both of the above.
Application.Wait (Now + TimeValue("0:00:01") * 0.5) and then set the height.
None of these worked.
To be able to scroll to the last item, this worked:
Listbox1.IntegralHeight = False
Listbox1.Height= x
Listbox1.IntegralHeight = False
Listbox1.Height= x
but this also set the Listbox1.Height to this of one single item. (with arrows at the right)
Does anybody know how on earth am I going to control the Listbox1.Height without all this unwanted behaviour? Also if somebody can suggest another structure that could follow the plan mentioned at first, I 'm willing to discard the listbox.
This seems to be a not completely explored behaviour.
In my experience just redefine some listbox arguments.
Try the recommended sets of .IntegralHeight to False and True.
Another possible measure can help in some cases: try to choose heights for your listbox that come close to the following multiplication:
listbox height = (font size + 2 pts) * (maximum items per page)
Insert the following code after With ListBox1:
With ListBox1
.Top = 18 ' << redefine your starting Point
.Font.Size = 10 ' << redefine your font size
.IntegralHeight = False ' << try the cited recommendation :-)
Insert the following code before End With:
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
Hope that helps.
Link
See another faster approach to filter listboxes at How to speed up filling of listbox values on userform excel
#T.M.: Thank you for your quick response and for your time. Your answer gave me exactly what I wanted and that's why I'm marking it as such. I'm posting this just for future reference.
What I finaly did to implement the plan.
First of all I inserted:
this
With ListBox1
.Top = 18
.Font.Size = 10
.IntegralHeight = False
and this
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
and I linked .Height with .Font.Size as you suggested. As long as there was no need to assign absolute values to the height, there was no need to have a Select Case statement in my code.
Moreover I realized that there was no need to change the height every time an item was added but only at the end of the process, so I took it out of the loop.
Finally I added a piece of code that would make the list invisible when Textbox1 was empty. The code is now like this:
Final Userform code:
Option Compare Text
Option Explicit
Private bsdel As Boolean 'indicates if backspace or delete keys have been hit.
Private Sub ListBox1_Click()
Dim cell As Range
Dim maxRow As Integer
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set cell = .Range("A1:A" & maxRow).Find(UserForm11.ListBox1.Text, LookIn:=xlValues, lookat:=xlWhole)
If Not cell Is Nothing Then
cell.Select
'do other stuff also.
End If
End With
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
bsdel = False
If KeyCode = 8 Or KeyCode = 46 Then _
bsdel = True
End Sub
Private Sub TextBox1_Change()
Dim srchWord As String, firstAddress As String
Dim srchRng As Range, cell As Range
Dim maxRow As Integer
ListBox1.Clear
ListBox1.Visible = True
If bsdel And TextBox1.Value = "" Then
ListBox1.Visible = False
Me.Height = 130
Else
With ThisWorkbook.Worksheets(1)
maxRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set srchRng = .Range("A1:A" & maxRow)
End With
srchWord = TextBox1.Value
Set cell = srchRng.Find(srchWord, LookIn:=xlValues, lookat:=xlPart)
With ListBox1
'.Top = 84 'test made: deleting this made no difference.
'.Font.Size = 10 'test made: deleting this made no difference.
.IntegralHeight = False
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not cell.Value Like "*(*" Then 'this range includes notes within parenthesis and I didn't need them.
.AddItem (cell.Value)
End If
Set cell = srchRng.FindNext(cell)
Loop While Not cell.Address = firstAddress
If .ListCount < 21 Then 'the size is adjusted.
.Height = (.Font.Size + 2) * .ListCount
Else 'the size stays fixed at maximum.
.Height = (.Font.Size + 2) * 20
End If
End If
Me.Height = .Height + 130
.Height = .Height + .Font.Size + 2
.IntegralHeight = True
End With
End If
bsdel = False
End Sub
Private Sub UserForm_Activate()
TextBox1.SetFocus
End Sub
Private Sub UserForm_Initialize()
ListBox1.Visible = False
End Sub
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