I am trying to create a Sub process which create a bunch of image and group it multiple times.
For First loop everything runs OK VBA Code runs as expected, On Second run VBA gives the error "Grouping is disable for selected shapes"
Sub PPT_AddShape14
x = 8 * (i - 1) + 170 * (i - 1)
y = 0
Set sh1 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 8, 170, 170)
Set sh2 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 178, 170, 30)
Set sh3 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 208, 170, 190)
vslide.Shapes.Range(Array("sh1", "sh2", "sh3")).Group.Name = Str(x)
Set Tiles = vslide.Shapes(Str(x))
End Sub
It's always a good idea to put Option Explicit at the top of every module and to properly declare your variables. But the issue with your code is that Range takes the NAMES of shapes as arguments, not strings that happen to match the names you've given the object variables you're using. This works:
Option Explicit
Sub PPT_AddShape14()
Dim i As Long
Dim x As Long
Dim y As Long
Dim sh1 As Shape
Dim sh2 As Shape
Dim sh3 As Shape
Dim vslide As Slide
Set vslide = ActivePresentation.Slides(1) ' as test
Dim Tiles As Shape
x = 8 * (i - 1) + 170 * (i - 1)
y = 0
Set sh1 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 8, 170, 170)
Set sh2 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 178, 170, 30)
Set sh3 = vslide.Shapes.AddShape(msoShapeRectangle, x + 8, y + 208, 170, 190)
vslide.Shapes.Range(Array(sh1.Name, sh2.Name, sh3.Name)).Group.Name = Str(x)
Set Tiles = vslide.Shapes(Str(x))
End Sub
Related
I have a VBA sub to create a few shapes, these shapes are then renamed to a cell value (B5:B15) and add text (C5:C15).
The shapes gets created, renamed and the text gets added but when I try to connect them I get the "Object Required".
Can some one please help me.
Thanks in advance.
Sub Button1_Click()
Dim s, conn As Shape, i As Integer
Set w = ActiveSheet
For i = 5 To 7
Set s = w.Shapes.AddShape(1, 800, i * 120 - 599, 100, 100)
s.Name = Range("B" & i)
s.TextFrame.Characters.Text = Range("C" & i)
s.Fill.ForeColor.RGB = RGB(0, 0, 213)
s.TextFrame.Characters.Font.ColorIndex = 19
Next i
Set conn = w.Shapes.AddConnector(1, 1, 1, 1, 1)
conn.ConnectorFormat.BeginConnect A001, 1
conn.ConnectorFormat.EndConnect A002, 1
End Sub
Something that would work:
Option Explicit
Sub Button1_Click()
Dim s As Shape, conn As Shape, i As Long
Dim w As Worksheet
Set w = ActiveSheet
Dim arr As Variant
ReDim arr(5 To 7)
For i = 5 To 7
Set s = w.Shapes.AddShape(1, 800, i * 120 - 599, 100, 100)
s.Name = Range("B" & i)
s.TextFrame.Characters.Text = Range("C" & i)
s.Fill.ForeColor.RGB = RGB(0, 0, 213)
s.TextFrame.Characters.Font.ColorIndex = 19
Set arr(i) = s
Next i
Set conn = w.Shapes.AddConnector(1, 1, 1, 1, 1)
conn.ConnectorFormat.BeginConnect arr(5), 1
conn.ConnectorFormat.EndConnect arr(6), 1
End Sub
What is the difference?
declaration of all variables - s is a Shape, i is a Long, w is a Worksheet;
the declaration is forced by Option Explicit;
a new variable arr is introduced, which keeps all the newly created forms. Thus the first form is kept under arr(5) and the last form is arr(7);
the BeginConnect and EndConnect need a variable which is a form. This is where we use the arr(5) to arr(7);
You can also refer to the shape, by its name and the Shapes() collection. Thus, the last 3 lines should look like this:
Set conn = w.Shapes.AddConnector(1, 1, 1, 1, 1)
conn.ConnectorFormat.BeginConnect w.Shapes("A001"), 1
conn.ConnectorFormat.EndConnect w.Shapes("A002"), 1
I have to create process maps in excel often and am trying to cut down on the excessive time it takes. instead of creating each shape and entering or pasting the text into the shape, with often 100 + steps. I am trying to write a code that will create a shape with the text from column D and will continue to do so until there is no text in the cell in column A. I have been able to create code to create the shapes but I cannot seem to have the text populate correctly in the separate blocks. Below is the code I have so far:
Sub addshapewithtext()
Dim BlankFound As Boolean
Dim x As Long
Dim w As Worksheet
Dim s As Shape
Dim t As Variant
Do While BlankFound = False
x = x + 1
Set t = Cells(x, "d")
Set w = ActiveSheet
Set s = w.Shapes.addshape(msoShapeFlowchartProcess, 200 + x * 200, 100, 100, 100)
'format shape
s.Fill.ForeColor.RGB = RGB(300, 300, 300)
s.Line.ForeColor.RGB = RGB(0, 0, 0)
s.Line.Weight = 3
'transparency
s.Fill.Transparency = 0
'add text from list
s.OLEFormat.Object.Formula = t
If Cells(x, "A").Value = "" Then
BlankFound = True
End If
Loop
End Sub
thank you for your help
Change s.OLEFormat.Object.Formula = t to s.OLEFormat.Object.Text = t
You may want to add in font size and color for the text in your shape as well
REVISED TO ADD
I went ahead and tweaked the procedure slightly and tested it:
Sub addshapewithtext()
Dim BlankFound As Boolean
Dim x As Long
Dim w As Worksheet
Dim s As Shape
Dim t As Variant
x = 1
Do Until Cells(x, "A").Value = ""
Set t = Cells(x, "d")
Set w = ActiveSheet
Set s = w.Shapes.AddShape(msoShapeFlowchartProcess, 200 + x * 200, 100, 100, 100)
'format shape
s.Fill.ForeColor.RGB = RGB(300, 300, 300)
s.Line.ForeColor.RGB = RGB(0, 0, 0)
s.Line.Weight = 3
'transparency
s.Fill.Transparency = 0
'add text from list
s.OLEFormat.Object.Text = t
If Cells(x, "A").Value = "" Then BlankFound = True
x = x + 1
Loop
End Sub
The code from the answer before me works great, but the text does not show because it's white.
To show the text in the process blocks you can give them a color with:
s.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
Code:
Sub addshapewithtext()
Dim BlankFound As Boolean
Dim x As Long
Dim w As Worksheet
Dim s As Shape
Dim t As Variant
x = 1
Do Until Cells(x, "A").Value = ""
Set t = Cells(x, "d")
Set w = ActiveSheet
Set s = w.Shapes.AddShape(msoShapeFlowchartProcess, 200 + x * 200, 100, 100, 100)
'format shape
s.Fill.ForeColor.RGB = RGB(300, 300, 300)
s.Line.ForeColor.RGB = RGB(0, 0, 0)
s.Line.Weight = 3
'Add color to text in process block
s.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
'transparency
s.Fill.Transparency = 0
'add text from list
s.OLEFormat.Object.Text = t
If Cells(x, "A").Value = "" Then BlankFound = True
x = x + 1
Loop
End Sub
I am trying to change the location of the graph that I generate with my vba. For now, it is just taking data from a column that may or may not change size. I understand I do not have 'Chart1' identified ion my code but I can not figure out where to declare it where it doesn't create another sheet for the chart as well.
reportsheet.Select
ActiveSheet.Range("a4", ActiveSheet.Range("a4").End(xlDown)).Select
ActiveSheet.Shapes.AddChart.Select
With ActiveSheet.Shapes("Chart1")
.Left = Range("A40").Left
.Top = Range("A40").Top
End With
You can change Name of active Chart and then assign the properties to it.
Try This...
reportsheet.Select
ActiveSheet.Range("A4", ActiveSheet.Range("A4").End(xlDown)).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.Parent.Name = "Chart1"
With ActiveSheet.Shapes("Chart1")
.Left = Range("A40").Left
.Top = Range("A40").Top
End With
I use make chart like this. Please refer to bellows.
Sub test()
Dim Ws As Worksheet
Set Ws = ActiveSheet
InsertCharts 20, Ws
InsertCharts 30, Sheets("Sheet1")
End Sub
Sub InsertCharts(n As Integer, Ws As Worksheet)
Dim Cht As Shape
Dim t As Single, w As Integer, h As Integer, x As Integer
Dim i As Integer
With Ws
If .ChartObjects.Count > 0 Then
.ChartObjects.Delete
End If
x = 0
t = .Range("a26").Top
w = 217.1338582677
h = 203.5275590551
For i = 1 To n
Set Cht = .Shapes.AddChart(, x, t, w, h)
If i Mod 5 = 0 Then
t = .Range("a26").Top
x = x + w + 20
Else
t = t + h + 20
End If
Next i
End With
End Sub
I receive the error: Method or data member not found at line
.SendKeys ("")
I am scraping from a screen and this the command I send to place the cursor in the right place before sending the command in the next line to change screens. I do not understand why I am receiving this error.
Sub RLinfo()
Dim sys
Dim sess
Dim chan
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim linecount As Long
' RL Information xxxx
Set Host = CreateObject("BZWh.WhllObj")
Host.OpenSession 0, 1, "xxxx.zmd", 30, 1
Set sess = Host.ActiveSession
Set chan = sess.Screen
Set ws = Worksheets("Information")
With ws
x = 14
y = 19
Set OUTPUTSHEET = ActiveWorkbook.Sheets("Information")
With chan
linecount = 2
Do While OUTPUTSHEET.Cells(linecount, 30) = "Zip"
RL = Format(OUTPUTSHEET.Cells(linecount, 1), "000000000")
.SendKeys ("<Home>")
.SendKeys ("/for x203<Enter>")
.waithostquiet (10)
.SendKeys (RL & "<Enter>")
.waithostquiet (10)
If Trim(.getstring(14, 2, 30)) = "RL WAS NOT FOUND" Then
OUTPUTSHEET.Cells(linecount, 20) = "RL No Longer In X203"
GoTo Found
Else
End If
OUTPUTSHEET.Cells(linecount, 17) = Trim(.getstring(11, 6, 6))
OUTPUTSHEET.Cells(linecount, 18) = Trim(.getstring(8, 27, 12))
OUTPUTSHEET.Cells(linecount, 19) = Trim(.getstring(9, 27, 12))
OUTPUTSHEET.Cells(linecount, 20) = Trim(.getstring(5, 41, 26))
For x = 14 To 20
If Trim(.getstring(x, 2, 7)) = "NUM" Then
OUTPUTSHEET.Cells(linecount, 21) = Trim(.getstring(x, 11, 11))
GoTo Found
Else
End If
Next x
If Trim(.getstring(23, 72, 6)) = "N MORE" Then
.SendKeys ("<PA1>")
.waithostquiet (10)
For y = 19 To 22
If Trim(.getstring(y, 2, 7)) = "NUM" Then
OUTPUTSHEET.Cells(linecount, 21) = Trim(.getstring(y, 11, 11))
GoTo Found
Else
End If
Next y
Else
End If
Found:
linecount = linecount + 1
Loop
End With
End With
ws.Cells(2, 31) = linecount
endM:
End Sub
The cause of my problem was that I was not disconnecting from the Host when I moved between modules. At the start of each module I was reconnecting to the Host even though I had not disconnected in the previous module and this caused the run time error.
I trying to get a third order LinEst function in VBA. However, the error always come out as Expected array when it reaches Ubound(xl).
Option Explicit
Sub RB()
Dim xl As Range, e As Double
Dim yl As Range, s As Variant
Dim X
With ThisWorkbook.Worksheets("Sheet1")
Set yl = .Range(.Cells(17, 7), .Cells(93, 7))
Set xl = .Range(.Cells(17, 1), .Cells(93, 1))
ReDim arrX3(1 To UBound(xl), 1 To 3) As Double
For i = LBound(xl) To UBound(xl)
arrX2(i, 1) = xl(i, 1)
arrX2(i, 2) = xl(i, 1) * xl(i, 1)
arrX2(i, 3) = xl(i, 1) * xl(i, 1) * xl(i, 1)
Next
X = Application.LinEst(yl, arrX3)
.Range(.Cells(12, 12), .Cells(15, 14)).Value = Application.Transpose(X)
End With
End Sub
xl is a Range and not an array. So, Ubound(xl) won't work. While I do not understand what you're code is trying to achieve, I believe that you are looking for something along the line like this:
Option Base 1
Option Explicit
Sub RB()
Dim xl As Range, e As Double
Dim yl As Range, s As Variant
Dim X As Variant, i As Long
e = 76
With ThisWorkbook.Worksheets("Sheet1")
Set yl = .Range(.Cells(17, 7), .Cells(e - 1, 7))
Set xl = .Range(.Cells(17, 1), .Cells(e - 1, 1))
Debug.Print "First row in xl is " & xl.Row
Debug.Print "Range xl has " & xl.Rows.Count & " rows"
Debug.Print "Last row in xl is " & xl.Rows.Count + xl.Row - 1
ReDim arrX3(1 To xl.Rows.Count, 1 To 3) As Double
For i = 1 To xl.Rows.Count
arrX3(i, 1) = xl.Cells(i, 1)
arrX3(i, 2) = xl.Cells(i, 1) * xl.Cells(i, 1)
arrX3(i, 3) = xl.Cells(i, 1) * xl.Cells(i, 1) * xl.Cells(i, 1)
Next i
X = Application.LinEst(yl, arrX3)
.Range(.Cells(12, 12), .Cells(15, 14)).Value = Application.Transpose(X)
End With
End Sub
Note, that I added a few Debug.Print which you might want to have a look at.
xl is declared to be a range and ranges don't have a Ubound.
Change the declaration of xl from Range to Variant and replace the line
Set xl = .Range(.Cells(17, 1), .Cells(93, 1))
by
xl = .Range(.Cells(17, 1), .Cells(93, 1)).Value
I'm not sure if this will be enough to make your code run as expected, but it will at least get rid of the error that you describe.