I have put a map into excel of a building seating chart and created activeX text boxes on each spot where someone is sitting. I also have a list of each seat and the person sitting there. What I want to do is go through the list and assign the correct name to the textbox for each person. The name of each textbox is "TextBox____" where the blank is the seat name". I am getting an error on the "set tbox" line.
Sub UpdateMap()
Dim name As Variant
Dim tbox As MSForms.TextBox
Dim rng As Range
Dim cell As Range
With ThisWorkbook.Worksheets("5th floor map")
Set rng = .Range("A2:A5")
For Each cell In rng
ws = cell.Value
name = Application.VLookup(ws, .Range("A2:B5"), 2, False)
Set tbox = ThisWorkbook.Worksheets("5th floor map").Shapes("TextBox" & ws)
tbox.Value = name
Next
End With
End Sub
I only used the first four names/seats for this example, and used the for loop because in reality there are over 100 of these. Any suggestions for how i could make this work would be appreciated. Or if I am thinking about this totally wrong, please tell me that too. Thanks.
try this
Sub UpdateMap()
Dim rng As Range
Dim cell As Range
With ThisWorkbook.Worksheets("5th floor map")
Set rng = .Range("A2:A5")
For Each cell In rng
.OLEObjects("TextBox" & cell).Object.Text = cell.Offset(0, 1).Value
Next
End With
End Sub
try this
Sub oo()
Dim ol As OLEObject
Set ol = ThisWorkbook.Worksheets("MySheet").OLEObjects("TextBox1")
With ol
.Object.Text = "blabla"
.Object.ForeColor = RGB(0, 0, 192)
.Object.BorderStyle = fmBorderStyleSingle
.Object.SpecialEffect = fmSpecialEffectFlat
.Object.BackColor = RGB(192, 192, 192)
'.object.....
End With
End Sub
Related
I've written a code to set pictures next to it's link in an excel sheet after it's done downloading. It is working smoothly but the problem is that every time i run the code it gets downloaded again and settled there. So if i delete one picture i see another one in that place. I hope there is a solution in if statement so that, if applied, it will omit downloading and go for the next loop if the cell is already filled in. I can't make it. If anybody helps me accomplish this, i would be very grateful. Thanks in advance.
Note: Links are in B column and pictures to get settled in C column.
Sub SetPics()
Dim pics As String
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
pics = cel.Offset(0, -1)
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Width = cel.Width
.Height = cel.Height
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
Next cel
End Sub
You need to scan the ActiveSheet (try not to use this, and replace it with Worksheets("YourSheetName")) for all Shapes.
For each Shape found, check it's TopLeftCell.Row property, if it equals the
cel.Row then the current picture already exists (from previous runs of this code), and you don't "re-insert" the picture.
Code
Sub SetPics()
Dim pics As String
Dim myPics As Shape
Dim PicExists As Boolean
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
PicExists = False ' reset flag
pics = cel.Offset(0, -1)
' loop through all shapes in ActiveSheet
For Each myPics In ActiveSheet.Shapes
If myPics.TopLeftCell.Row = cel.Row Then ' check if current shape's row equale the current cell's row
PicExists = True ' raise flag >> picture exists
Exit For
End If
Next myPics
If Not PicExists Then '<-- add new picture only if doesn't exist
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.WIDTH = cel.WIDTH
.HEIGHT = cel.HEIGHT
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
End If
Next cel
End Sub
In Word I have a document with multiple tables full of data. Hidden inside these cells (out of view but the data is there) is the Hex code of the color I want to shade the cells. I chose the hex value just because it's relatively short and it's a unique bit of text that won't be confused with the rest of the text in the cell.
I've found some code online to modify but I can't seem to make it work. It doesn't give any errors, just nothing happens. I feel like the problem is in searching the tables for the text value but I've spent hours on this and I think I've confused myself now!
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
If oRng = "CCFFCC" Then
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
End If
If oRng = "FFFF99" Then
oCel.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
Next
Next
End Sub
Thanks!
Edit:
I've also tried this code wit the same result of nothing happening:
Sub EachCellText()
Dim oCell As Word.Cell
Dim strCellString As String
For Each oCell In ActiveDocument.Tables(1).Range.Cells
strCellString = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 1)
If strCellString = "CCFFFF" Then
oCell.Shading.BackgroundPatternColor = wdColorLightGreen
If strCellString = "CCFFCC" Then
oCell.Shading.BackgroundPatternColor = wdColorLightYellow
If strCellString = "FFFF99" Then
oCell.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
End If
End If
Next
End Sub
Your Code is getting stuck nowhere. But you are checking the whole Cell Value against the Hex code, and this will not work since "blablabla FFFFFF" is never equal to "FFFFFF". So you have to check if the Hex code is in the Cell value:
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Dim cellvalue As String
'check if Colorcode is in cell
If InStr(oRng, "CCFFCC") Then
'Set Cell color
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
'Remove Colorcode from Cell
cellvalue = Replace(oRng, "CCFFCC", "")
'load new value into cell
oRng = cellvalue
End If
Next
Next
End Sub
Now you just have to add all the colors you want to use (I would prefer a Select Case statement) and the code should work fine
I want to open an Excel file, go to the first sheet in the file, and change the text colour of textbox1 to red.
The only way I have managed to do it so far is via recording the macro.
It gives me
Workbooks.Open (fPath & sName)
Sheets(1).Select
ActiveSheet.Shapes.Range(Array("TextBox1")).Select
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 262).Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
That's fine; however the length of the text is variable so I get an error with the code if it is less than the 262 characters above.
I tried to introduce
CharCount = Len(textbox1.Text)
However I get error 424 Object required
I initially tried
Sheets(1).Select
ActiveSheet.TextBox1.ForeColor = RGB(255, 0, 0)
but got error 438 Object doesn't support this property or method.
If you want to change the font colour of the entire textbox (i.e. not just certain characters) then skip the Characters method. Also you shouldn't rely on .Select, ActiveSheet and the likes. Set proper references instead.
This works:
Dim wb As Workbook
Dim ws As Worksheet
Dim s As Shape
Set wb = Workbooks.Open(fPath & sName)
Set ws = wb.Sheets(1)
Set s = ws.Shapes("TextBox 1")
s.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
try this,
Sub Button2()
Dim sh As Shape
Set sh = Sheets("Sheet1").Shapes("Textbox1")
sh.TextFrame.Characters.Font.Color = vbRed
End Sub
I'm using Excel 2000 (long story) and I conditionally set the color of text box "M_in_out" in "Sheet7" with the following.
Private Sub M_in_out_LostFocus()
Dim sh As Sheet7
Set sh = Sheet7
vx = CInt(M_in_out.Value)
If vx > 0 Then
sh.M_in_out.ForeColor = vbBlack
Else
sh.M_in_out.ForeColor = vbRed
End If
sh.Cells(23, 6).Value = sh.Cells(23, 6).Value + vx
End Sub
You should probably use more meaningful variable names etc!.
I have a spreadsheet that is used for tracking work orders. The first column of the sheet has numbers starting at 14-0001 and continue sequentially all the way down. The numbers were hyperlinked to the .XLS of their respective work order (ex. the cell containing 14-0001 links to Z:\WorkOrders\14-0001-Task Name\14-0001-Task Name.xls)
Problem is, My computer crashed and when Excel recovered the file all the hyperlinks changed from:
**"Z:\blah blah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
to
**"C:\Users\blahblah\WorkOrders\14-****-Task Name\14-****-Task Name.xls"**
There are hundreds of entries so I was hoping that I could run a script to fix all of the hyperlinks.
Heres a script I found online which from what I understood is supposed to do what I want, but when I run the script from the VB window in Excel I get "Compile error: Argument not optional" and it highlights Sub CandCHyperlinx()
Code:
Option Explicit
Sub CandCHyperlinx()
Dim cel As Range
Dim rng As Range
Dim adr As String
Dim delstring As String
'string to delete: CHANGE ME! (KEEP quotes!)
delstring = "C:\Users\***\AppData\Roaming\Microsoft\Excel\"
'get all cells as range
Set rng = ActiveSheet.UsedRange
'ignore non hyperlinked cells
On Error Resume Next
'check every cell
For Each cel In rng
'skip blank cells
If cel <> "" Then
'attempt to get hyperlink address
adr = cel.Hyperlinks(1).Address
'not blank? then correct it, is blank get next
If adr <> "" Then
'delete string from address
adr = Application.WorksheetFunction.Substitute(adr, delstring)
'put new address
cel.Hyperlinks(1).Address = adr
'reset for next pass
adr = ""
End If
End If
Next cel
End Sub
Is this even the right script? What am I doing wrong?
Try this:
Sub Macro1()
Const FIND_TXT As String = "C:\" 'etc
Const NEW_TXT As String = "Z:\" 'etc
Dim rng As Range, hl As Hyperlink
For Each rng In ActiveSheet.UsedRange.Cells
If rng.Hyperlinks.Count > 0 Then
Set hl = rng.Hyperlinks(1)
Debug.Print rng.Address(), "Before", hl.TextToDisplay, hl.Address
hl.TextToDisplay = Replace(hl.TextToDisplay, FIND_TXT, NEW_TXT)
hl.Address = Replace(hl.Address, FIND_TXT, NEW_TXT)
Debug.Print rng.Address(), "After", hl.TextToDisplay, hl.Address
End If
Next rng
End Sub
I've just had the same problem, and all the macros I tried didn't work for me. This one is adapted from Tim's above and from this thread Office Techcentre thread. In my case, all my hyperlinks were in column B, between rows 3 and 400 and 'hidden' behind the filename, and I wanted to put the links back to my Dropbox folder where they belong.
Sub FixLinks3()
Dim intStart As Integer
Dim intEnd As Integer
Dim strCol As String
Dim hLink As Hyperlink
intStart = 2
intEnd = 400
strCol = "B"
For i = intStart To intEnd
For Each hLink In ActiveSheet.Hyperlinks
hLink.TextToDisplay = Replace (hLink.TextToDisplay, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
hLink.Address = Replace(hLink.Address, "AppData/Roaming/Microsoft/Excel",
"Dropbox/References")
Next hLink
Next i
End Sub
Thanks for your help, Tim!
I have a named range lstVendors that refers to: =OFFSET(Data!$W$2,0,0,COUNTA(Data!$W$2:$W$400),1). I want this range to be populated when the workbook opens. I have the following code for this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Range("lstVendors").Offset(0, 0).Value = "Please Select..."
' Set DropDown1 = ThisWorkbook.Sheets("Dashboard").DropDowns("Drop Down 1")
' DropDown1.Value = 1
On Error Resume Next
If Not IsError(Range("lstVendors")) Then
Range("lstVendors").ClearContents
End If
On Error GoTo 0
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
Set startRng = Range("lstVendors")
i = 0
For n = 2 To UBound(rslt)
Range("lstVendors").Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
It errors on the Set startRng = Range("lstVendors"). I know this is because there's nothing in the range when I'm trying to set it, because if I put one entry into the named range, the set works, however, I need it populated by the sqlite query on each open as the data changes.
Any suggestions much appreciated.
Try this. You have a dynamic range that doesn't evaluate after you clear the contents. To avoid this, there are probably several ways, but easy to simply hardcode the startRange variable so that it always points to Data!$W$2 address, which is (or rather, will become) the first cell in your lstVendors range.
Private Sub Workbook_Open()
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
Dim rngList As Range
'// Define your startRange -- always will be the first cell in your named range "lstVendors"
' hardcode the address because the dynamic range may not evalaute.
Set startRange = Sheets("Data").Range("W2")
'// Empty th lstVendors range if it exists/filled
On Error Resume Next
Range("lstVendors").Clear
On Error GoTo 0
'// Run your SQL query
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
i = 0
'// Print results to the Worksheet, beginning in the startRange cell
For n = 2 To UBound(rslt)
'Increment from the startRange cell
startRange.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
'Verify that "lstVendors" is being populated
Debug.Print Range("lstVendors").Address
Next n
End Sub
Thanks for the suggestions. Here is what I ended up doing in order to get around my problem. It involves adding something I didn't specify would be ok in my original question, so David's answer is great if what I did isn't an option. I first populated the first two cells in my named range with "Please Select..." and "All". In Sub Workbook_Open() we do this:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
Dim rslt()
Dim i As Integer
Dim n As Integer
Dim startRng As Range
Dim DropDown1 As DropDown
' Disable our not found message
ThisWorkbook.Sheets("Dashboard").Shapes("TextBox 6").Visible = False
' Set our start range to our named range
Set startRng = Range("lstVendors")
' Grab all vendor names
rslt = Application.Run("SQLite_Query", "path/to/my/sqlite", "SELECT PROGRAM_ID FROM VENDOR;")
' Print result. Skip first two rows as constants "Please Select..." and "All" are populated there
i = 2
For n = 2 To UBound(rslt)
startRng.Offset(i, 0).Value = rslt(n)(0)
i = i + 1
Next n
End Sub
Then we will create Sub Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Disable the save changes dialog. This workbook will be locked up for display only. No need to confuse the user.
Application.DisplayAlerts = False
' Clear everything below the "Please Select..." and "All" cells in the named range
On Error Resume Next
Range("lstVendors").Offset(2, 0).ClearContents
On Error GoTo 0
' Save the changes to the named range
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub
This information is going to populate a drop down, so having Please Select and All hardcoded into the named range is acceptable for me. If that stipulation doesn't work for someone else looking at this in the future, please use David's suggestion! Thanks again!