I would like to move a photo to the bottom of cell but it does not work please help me?
.Top = Target.Top -> .Bottom = Target.Bottom
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Or Target.Row = 1 Then Exit Sub
On Error Resume Next
Target(, 2).Worksheet.Shapes(Target.Address).Delete
On Error GoTo Thoat
Copy_Images Target.Value
ActiveSheet.PasteSpecial
With Selection
.Name = Target.Address
.Top = Target.Top
.Left = Target(, 2).Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = Target.Height
.ShapeRange.Width = Target(, 2).Width
End With
Thoat:
Target.Offset(1, 0).Select
End Sub
Private Sub Copy_Images(imageName As String)
Dim sh As Shape
For Each sh In Sheets(2).Shapes
If sh.Name = imageName Then
sh.Copy
'Sheets(1).Pictures.Paste
End If
Next
End Sub
Thanks!
I want to Resize Column to Fit Picture please help me:
With Selection
.Name = Target.Address
.Top = Target.Top
.Left = Target(, 2).Left
.ShapeRange.LockAspectRatio = msoFalse
'.ShapeRange.Height = Target.Height
'.ShapeRange.Width = Target(, 2).Width
End With
There's no Bottom property, so you need something like
.Top = Target.Top + Target.Height
Related
I want to insert an image on every page.
I know that the command is Next in a For loop.
Sub InsertImage()
Dim oILS As InlineShape, oShp As Shape
Set oILS = Selection.InlineShapes.AddPicture(FileName:= _
"C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png", LinkToFile:=False, _
SaveWithDocument:=True)
Set oShp = oILS.ConvertToShape
With oShp
.WrapFormat.Type = wdWrapBehind
.Left = -55
.Top = 471.1
.Height = 21.5
.Width = 522
End With
End Sub
Well, I found the way to do it on all pages. If it helps anyone, here it is:
Sub Demo()
Dim Rng As Range, i As Long, Shp As Shape, ImageName As String
ImageName = "C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png"
With ActiveDocument
Set Rng = .Range(0, 0)
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = Rng.GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
Rng.Collapse wdCollapseStart
Set Shp = .InlineShapes.AddPicture(FileName:=ImageName, SaveWithDocument:=True, Range:=Rng).ConvertToShape
With Shp
.Left = -55
.Top = 471.1
.Width = 522
.Height = 21.5
.WrapFormat.Type = wdWrapBehind
End With
Next
End With
End Sub
In a merged cell (named as SelName) I have a dropdown list with more then 100 items. Searching through the list is not efficient, as this list is constantly growing. Therefore, I would like to have a dropdown list with autocomplete/ suggestion function. One of the codes that I have is the following which I have found on extendoffice.com:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2017/8/15
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
First, I tried to test it in an empty sheet (with just the dropdown list) and it worked well. But as soon as I try to insert this code into the other worksheet, it doesn't. Does anyone has an idea what the problem could be?
FYI: I have several drop down lists in this worksheet and all of them are in merged cells. Additionally, I have some other Private subs...
Why do you have to do that instead of just creating a ComboBox control and setting ListFillRange and LinkedCell without any code?
The error happens because the Range you are editing (Target) does not have any Validation. You should add the check for validation:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim vType As XlDVType
On Error GoTo EndLine
vType = Target.Validation.Type
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim Cancel As Boolean
Set xWs = Application.ActiveSheet
'On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If vType = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
EndLine:
End Sub
EDIT
If i understand the problem correctly, you want a ComboBox that auto-fills from a column and auto-updates if you type more entries in the column. There is no need for such complicated code. You can simply add a ComboBox (say ComboBox1), set its ListFillRange (e.g. to A1:A20) and do this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With ComboBox1
Dim OrigRange As Range: OrigRange = .ListFillRange
If Not Application.Intersect(OrigRange, Target) Is Nothing Then
.ListFillRange = .OrigRange.Resize(OrigRange.Cells(1).End(xlDown).Row - OrigRange.Row + 1)
End If
End With
End Sub
Autocomplete Dropdowns are now native with excel O365
https://www.excel-university.com/autocomplete-for-data-validation-dropdown-lists/
I have a worksheet with Activex Controls(Combobox, Command Button, Option Button, CheckBox).
On my computer I have renamed all the controls (Ex. CButtonPMR, OButton_Comp, etc)
But when I open the file on other computer all the controls are renamed to default the default names (CheckBox1,Checkbox2, CommandButton1, etc)
For that reason the code doesn't works on other computers.
I am getting errors every time because the code can't compile.
Is there a way to fix this?
I basically have 2 forms into one and there is 2 option button to chose wich one you want.
When the user select a Button the other form is Hidden
Private Sub OpButtonComp_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = True
ActiveSheet.Rows("62:86").Hidden = False
ActiveSheet.Rows("6").Hidden = True
Dim rng As Range
Set rng = ActiveSheet.Range("A62:P62")
With ActiveSheet.OLEObjects("CButtonPMB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPMB").Visible = True
Set rng = ActiveSheet.Range("A72:P72")
With ActiveSheet.OLEObjects("CButtonMQSB")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQSB").Visible = True
Set rng = ActiveSheet.Range("A79:P79")
With ActiveSheet.OLEObjects("CButtonMQS2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonMQS2B").Visible = True
Set rng = ActiveSheet.Range("A85:P85")
With ActiveSheet.OLEObjects("CButtonPM2B")
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
End With
ActiveSheet.OLEObjects("CButtonPM2B").Visible = True
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
Private Sub OpButtonCon_Click()
Dim protect As Boolean
protect = False
If ActiveSheet.ProtectContents Then
protect = True
ActiveSheet.Unprotect Password:="password"
End If
Application.ScreenUpdating = False
ActiveSheet.Rows("13:61").Hidden = False
ActiveSheet.Rows("62:86").Hidden = True
ActiveSheet.Rows("6").Hidden = False
ActiveSheet.CButtonPMB.Visible = False
ActiveSheet.CButtonMQSB.Visible = False
ActiveSheet.CButtonMQS2B.Visible = False
ActiveSheet.CButtonPM2B.Visible = False
Application.ScreenUpdating = True
If Not (ActiveSheet.ProtectContents) And protect = True Then
ActiveSheet.protect Password:="password"
End If
End Sub
This is to pop up a DatePicker Form when those cells are selected.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' Only look at that range
If Intersect(Target, Range("N12:P12")) Is Nothing _
And Intersect(Target, Range("N15:P15")) Is Nothing _
And Intersect(Target, Range("N29:P29")) Is Nothing _
And Intersect(Target, Range("N37:P37")) Is Nothing _
And Intersect(Target, Range("N44:P44")) Is Nothing _
And Intersect(Target, Range("N50:P50")) Is Nothing _
And Intersect(Target, Range("N51:P51")) Is Nothing _
And Intersect(Target, Range("N59:P59")) Is Nothing _
And Intersect(Target, Range("N70:P70")) Is Nothing _
And Intersect(Target, Range("N78:P78")) Is Nothing _
And Intersect(Target, Range("N83:P83")) Is Nothing Then
Exit Sub
Else
'Show Datepicker
CalendarFrm.Show
End If
End Sub
Thank you
Since my answer was deleted I'll post the solution here.
If anyone is wondering, I managed to fix it by following this http://www.excelclout.com/microsoft-update-breaks-excel-activex-controls-fix/
Copy and paste the following VBA code into any module in the spreadsheet.
Public Sub RenameMSFormsFiles()
Const tempFileName As String = "MSForms - Copy.exd"
Const msFormsFileName As String = "MSForms.exd"
On Error Resume Next
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\Excel8.0\MSForms.exd file
RenameFile Environ("TEMP") & "\Excel8.0\" & msFormsFileName, Environ("TEMP") & "\Excel8.0\" & tempFileName
'Try to rename the C:\Users\[user.name]\AppData\Local\Temp\VBE\MSForms.exd file
RenameFile Environ("TEMP") & "\VBE\" & msFormsFileName, Environ("TEMP") & "\VBE\" & tempFileName
End Sub
Private Sub RenameFile(fromFilePath As String, toFilePath As String)
If CheckFileExist(fromFilePath) Then
DeleteFile toFilePath
Name fromFilePath As toFilePath
End If
End Sub
Private Function CheckFileExist(path As String) As Boolean
CheckFileExist = (Dir(path) <> "")
End Function
Private Sub DeleteFile(path As String)
If CheckFileExist(path) Then
SetAttr path, vbNormal
Kill path
End If
End Sub
Call the RenameMSFormsFiles subroutine at the very beginning of the workbook_Open event.
Private Sub Workbook_Open()
RenameMSFormsFiles
End Sub
Here is my code; when I lock the sheet the code stops working and will not pop up on the double click.
On another note is there a way to activate the code without requiring it to double click?
Private Sub Worksheet_Activate()
End Sub
'==========================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
'clear and hide the combo box
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo errHandler
If Target.Validation.Type = 3 Then
'if the cell contains a data validation list
Cancel = True
Application.EnableEvents = False
'get the data validation formula
str = Target.Validation.Formula1
str = Right(str, Len(str) - 1)
With cboTemp
'show the combobox with the list
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = str
.LinkedCell = Target.Address
End With
cboTemp.Activate
'open the drop down list automatically
Me.NameBox.DropDown
End If
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'=========================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim str As String
Dim cboTemp As OLEObject
Dim ws As Worksheet
Set ws = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = True
If Application.CutCopyMode Then
'allow copying and pasting on the worksheet
GoTo errHandler
End If
Set cboTemp = ws.OLEObjects("NameBox")
On Error Resume Next
With cboTemp
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With
errHandler:
Application.EnableEvents = True
Exit Sub
End Sub
'====================================
'Optional code to move to next cell if Tab or Enter are pressed
'from code by Ted Lanham
'***NOTE: if KeyDown causes problems, change to KeyUp
Private Sub NameBox_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
Select Case KeyCode
Case 9 'Tab
ActiveCell.Offset(0, 1).Activate
Case 13 'Enter
ActiveCell.Offset(1, 0).Activate
Case Else
'do nothing
End Select
End Sub
'====================================
Sub InsertLogo1()
ActiveCell.Select
ActiveSheet.Pictures.Insert("Path").Select
End Sub
Dim Pic As Object
Set Pic = ActiveSheet.Pictures.Insert(Directory & "\" & filename)
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.LockAspectRatio = msoTrue
.Width = 225#
End With