In this link, i use SHP.OnAction (where Dim SHP As Shape) to print the name of the macro which is assigned to a shape.
Now I would like to check if SHP.OnAction is empty, which means there is no macro assigned to this object.SHP.OnAction = "" does not work, it always return false. I have tried also ``SHP.OnAction = Empty,SHP.OnAction = Null, they always returnfalse` too...
Could anyone tell me how to verify if it is empty?
Edit1: I use the following piece of code, to go through all the shapes in a workbook, and check if there is a shape to that a macro is assigned. I test it with some workbooks containing Chart or Picture, it seems that sShpaes.OnAction <> "" returns always true, even though the shape has no macro...
On Error Resume Next
Dim sShapes As Shape
existsAssignedShape = False
For Each ws In Worksheets
For Each sShapes In ws.Shapes
st = ws.Name & " " & sShapes.Name & " " & sShapes.OnAction
Print #1, st
Print #1, ""
If (Not existsAssignedShape) And (sShpaes.OnAction <> "") Then
existsAssignedShape = True
End If
Next sShapes
Next ws
If no macro has been assigned to an AutoShape, then the following will indicate True:
Sub hgfd()
Dim s As Shape, t As String
Set s = ActiveSheet.Shapes(1)
t = CStr(s.OnAction)
MsgBox t = ""
End Sub
Related
I am attempting to write a vba loop that will detect the value of all ActiveX textboxes on the slide. However I am have trouble writing the code for the "variable" in the textbox reference. For example TextBox(i) needs to be referenced in the loop. Where i is an integer I set the value to.
Dim i as Integer
For i = 1 to 4
If IsNull(Slide1.Shapes.("TextBox" & i).Value) = True
Then (Slide1.Shapes.("TextBox" & i).Value) = 0
Else: ...
Next i
However this script doesn't work and I have been unable to locate a source for how to properly code this variable portion of script. There has been some talk of using Me.Controls however I am not creating a form. Would anyone be willing to share what the error is here in my script?
This will put the value of i into TextBox i. Should get you started, I think.
Sub Example()
Dim oSh As Shape
Dim i As Integer
On Error Resume Next
For i = 1 To 4
Set oSh = ActivePresentation.Slides(1).Shapes("TextBox" & CStr(i))
If Err.Number = 0 Then ' shape exists
oSh.OLEFormat.Object.Text = CStr(i)
End If
Next i
End Sub
#Steve Rindsberg you had the correct code. Thank you. Here was the final script to obtain the value, and set the value if blank.
For i = 1 To 4
'set oSh to TextBox1, TextBox2, TextBox3... etc.
Set oSh = ActivePresentation.Slides(1).Shapes("TextBox" & CStr(i))
'set myVar to value of this TextBox1, TextBox2...
myVar = oSh.OLEFormat.Object.Value
If myVar = "" Then _
ActivePresentation.Slides(1).Shapes("Text" & CStr(i)).OLEFormat.Object.Value = 0 _
Else: 'do nothing
'clear value of myVar
myVar = ""
'start on next integer of i
Next i
I have wrote some VBA code which I was fairly happy with. It went through a list on a worksheet, switched to another and set a variable (and thus changed some graphs) and then opened word, copied in the graphs to various bookmarks and saved the document as the variable name.
It worked like a charm and I was a happy boy (saved a good week and a bit of work for someone). I have not touched it since - or the worksheets for that matter - opened it today and it is giving me a type missmatch on the first lot. I would really love some advice as it has left me scratching my head.
Public X As Integer
Public Y As String
Sub Macro2()
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Sheets("CPD data 13-14").Select
Range("A" & LoopCounter).Select
Y = Range("A" & LoopCounter).Value
'Change the chart values
Sheets("Pretty Display (2)").Select
Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
The error hits on the following line:
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
EDIT
As suggested I have updated my code not to use select so it now reads:
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
'Change the chart values
pd.Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = pd.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
I still get the same runtime error at the same point.
try this
Option Explicit
Public X As Integer
Public Y As String
Sub Macro2()
Dim wordApp As Object
Dim LoopCounter As Integer
Dim Mystring As String
Dim ws As Worksheet, pd As Worksheet
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
' open one Word session for all the documents to be processed
Set wordApp = CreateObject("word.Application")
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
With pd
.Range("A1").Value = Y 'Change the chart values
.ChartObjects("Chart 3").Copy ' Copy the chart
End With
'act on Word application
With wordApp
'open word template
.documents.Open "LOCATION"
.Visible = True
' paste into bookmarks, "save as" document and close it
With .ActiveDocument
.Bookmarks("InstitutionName").Range = Y
.Bookmarks("Graph1").Range.PasteSpecial
Mystring = Replace(Y, " ", "")
.SaveAs Filename:="LOCATION" & Mystring & ".docx"
.Close
End With
End With
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
'Close Word
wordApp.Quit
Set wordApp = Nothing
End Sub
I couldn't have a word "Range" object directly set to an Excel "Chart" object
So I had to copy the chart and use "PasteSpecial" method of the Word "Range" object
Furthemore I worked with one Word session only, which'd result in a faster job
Finally I also made some "comsetics" to make the code more readable/maintanable
just as a suggestion: I'd always use "Option Explicit" statement. that'll force you some extra work to explicitly declare each and every variable you use, but that will also give much more control over your work and result in less debbugging issues, thus saving time at the end
My advice is to set the Explicit flag and try to decompile the code. Any variables that you didn't dimension will throw an error. This is a good time to dimension the variable and type the data appropriately.
If that doens't throw an error, which it should since you have at least one variable LoopCounter that isn't dimensioned and could therefore cause data type errors then try changing Public X As Integer to Public X As Long so as to avoid values beyond the limit of the Integer data type.
.Activate is sometimes necessary even when using .Select from my experience. Selecting a worksheet should make it the active worksheet, but that's not always the case.
I want to write a macro that will pick a particular value (in my case, stored in cell A1) from a dropdown list (in my case, in cell D6).
Here's what I have so far:
sr_par2 = Array ("TEXT", 'TEXT2", "TEXT3")
sr = Range("A1").Value
(...)
Dim i As Integer
i = 0
Range("D6").Select
Do While (sr <> ActiveCell.FormulaR1C1)
Range("D6").Select
ActiveCell.FormulaR1C1 = sr_par2(i)
i = i + 1
Loop
Is this what you are trying? I have commented the code so that you will not have a problem understanding it. Still if you do then simply ask :)
Sub Sample()
Dim ws As Worksheet
Dim rngIn As Range, rngOut As Range
Dim MyAr
Dim sFormula As String
Dim i As Long
'~~> Replace this with the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Set your input and output range here
Set rngIn = .Range("A1")
Set rngOut = .Range("D6")
'~~> Get the validation list if there is one
On Error Resume Next
sFormula = rngOut.Validation.Formula1
On Error GoTo 0
If sFormula = "" Then
'~~> If no validation list then directly populate the value
rngOut.Value = rngIn.Value
Else
'validation list TEXT1,TEXT2,TEXT3
MyAr = Split(sFormula, ",")
'~~> Loop through the list and compare
For i = LBound(MyAr) To UBound(MyAr)
If UCase(Trim(rngIn.Value)) = UCase(Trim(MyAr(i))) Then
rngOut.Value = MyAr(i)
Exit For
End If
Next i
'~~> Check if the cell is still blank. If it is then it means that
'~~> Cell A1 has a value which is not part of the list
If Len(Trim(rngOut.Value)) = 0 Then
MsgBox "The value in " & rngOut.Address & _
" cannot be set as the value you are copying is not part of the list"
End If
End If
End With
End Sub
If I understood correctly, this should do what you want :
sr_par2 = Array("TEXT", "TEXT2", "TEXT3")
sr = Range("A1").Value
Dim i As Integer
i = 0
On Error GoTo Handler
Do While (sr <> sr_par2(i))
i = i + 1
Loop
Range("D6").FormulaR1C1 = sr_par2(i)
Exit Sub
Handler:
MsgBox "Value not in the list", vbCritical + vbOKOnly, "Value not found"
new to VBA here. I've been stuck on this problem for a while now:
Essentially, I need to create a macro that copies over specific data from one sheet to another, that is up to the user to specify. The catch is that while all the data is in one column (B), not all rows of the column have relevant entries; some are blank and some have other data that I don't want.
Only entries that begin with 4 numbers are wanted. I can't seem to get how the iterated copy-pasting works; what I've come up with is as follows:
'defining input
Dim dater As Date
dater = Range("B2")
If dater = False Then
MsgBox "Date not specified"
Exit Sub
End If
Dim sheetin As String
sheetin = Range("B5")
If sheetin = "" Then
MsgBox "Input Sheet not specified"
Exit Sub
End If
Dim wbin As String
wbin = Range("B4")
If wbin = "" Then
MsgBox "Input workbook not specified"
Exit Sub
End If
Dim sheetout As String
sheetout = Range("B9")
If sheetout = "" Then
MsgBox "Output Sheet not specified"
Exit Sub
End If
Dim wbout As String
wbout = Range("B8")
If wbout = "" Then
MsgBox "Output Workbook not specified"
Exit Sub
End If
Windows(wbout).Activate
Dim sh As Worksheet, existx As Boolean
For Each sh In Worksheets
If sh.Name Like sheetout Then existx = True: Exit For
Next
If existx = True Then
If Sheets(sheetout).Visible = False Then Sheets(sheetout).Visible = True
Else
Sheets.Add.Name = CStr(sheetout)
End If
'copy pasting values
Windows(wbin).Activate
Sheets(sheetin).Select
'specify maximum row
iMaxRow = 500
For iRow = 1 To iMaxRow
With Worksheets(sheetin).Cells(iRow, 2)
'Check that cell is not empty.
If .Value = "####*" Then
.Copy Destination:=Workbooks(wbout).Worksheets(sheetout).Range("A" & i)
'Else do nothing.
End If
End With
Next iRow
End Sub
Subsequently i'll have to match data to these entries that have been copied over but I figure once i get the hang of how to do iterated stuff it shouldn't be too much of a problem. But right now i'm really stuck... Please help!
It looks like it should work, except for that part :
With Worksheets(sheetin).Cells(iRow, 2)
If .Value = "####*" Then
.Copy Destination:=Workbooks(wbout).Worksheets(sheetout).Range("A" & i)
End If
End With
The third line contains an unknown variable : i.
You need to define it to contain the number of the line to which you're copying. For example, if you want to copy to the first available line, try this :
Set wsOut = Workbooks(wbout).Worksheets(sheetout)
With Worksheets(sheetin).Cells(iRow, 2)
If .Value = "####*" Then
i = wsOut.Cells(wsOut.Rows.Count, 1).End(xlUp).Row + 1
.Copy Destination:=wsOut.Range("A" & i)
End If
End With
I want to display to the user certain information that exists on a separated worksheet, whenever he clicks a button.
I can set Excel to "go" to this worksheet at the starting line of the range , but I could not find a way to hide everything else.
Is there some method for this, or do I have to hide all rows and columns?
Insert a UserForm in the Workbook's VB Project.
Add a ListBox control to the userform.
Then do something like this code in the UserForm_Activate event code:
Private Sub UserForm_Activate()
Dim tbl As Range
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
Me.Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With ListBox1
.ColumnHeads = False
.ColumnCount = tbl.Columns.Count
.RowSource = tbl.Address
End With
End Sub
Which gives unformatted data from the range:
To export the range as an image, you could create an Image in the UserForm instead of a Listbox. Then this should be enough to get you started.
As you can see from this screenshot, the image might not always come out very clearly. Also, if you are working with a large range of cells, the image might not fit on your userform, etc. I will leave figuring that part out up to you :)
Private Sub UserForm_Activate()
Dim tbl As Range
Dim imgPath As String
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
imgPath = Export_Range_Images(tbl)
Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With Image1
If Not imgPath = vbNullString Then
.Picture = LoadPicture(imgPath)
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = 2 'Center
.PictureTiling = False
.SpecialEffect = 2 'Sunken
End If
End With
End Sub
Function Export_Range_Images(rng As Range) As String
'## Modified by David Zemens with
' credit to: _
' http://vbadud.blogspot.com/2010/06/how-to-save-excel-range-as-image-using.html ##'
Dim ocht As Object
Dim srs As Series
rng.CopyPicture xlScreen, xlPicture
ActiveSheet.Paste
Set ocht = ActiveSheet.Shapes.AddChart
For Each srs In ocht.Chart.SeriesCollection
srs.Delete
Next
'## Modify this line as needed ##'
fname = "C:\users\david_zemens\desktop\picture.jpg"
On Error Resume Next
Kill fname
On Error GoTo 0
ocht.Width = rng.Width
ocht.Height = rng.Height
ocht.Chart.Paste
ocht.Chart.Export Filename:=fname, FilterName:="JPG"
Application.DisplayAlerts = False
ocht.Delete
Application.DisplayAlerts = True
Set ocht = Nothing
Export_Range_Images = fname
End Function
If you record a macro and hide some columns and rows manually, the code will be produced for you, and you will see how it's done.