PDA

View Full Version : EXCEL VBA SHAPE OBJECT, BUTTON, WORKSHEET HELP



victor222
11-03-2016, 11:42 AM
Hello All,


I sincerely would like some help with these Excel vba problem am stuck with. I already have some code written which i am trying to manipulate to achieve what i wanted, but certainly not working.


Here is my code:

Sub add_lamb()
Dim lamb As Shape
Dim ws As Worksheet
Dim iNumlamb As Variant
Dim i As Long
iNumlamb = InputBox("How many lamb ? ")
If Len(iNumlamb) = 0 Or iNumlamb < 1 Then Exit Sub
Sheets(1).Select
Range(Cells(1, 1), Cells(1000, 100)).Clear 'this should apply to the shapes not cells
With Worksheets("Sheet1")
For i = 1 To iNumlamb
.Cells(8, 2 + i).Value = "L" & i
If Not .Cells(11, 2 + i).Value = "" Then
.Cells(8, 2 + i).Interior.Color = RGB(100, 200, 255)
End If
Next i
End With
Set ws = ActiveSheet
Set lamb = ws.Shapes.AddShape(1, 200, 55, 40, 20)
lamb.Fill.ForeColor.RGB = RGB(100, 200, 255)
lamb.TextFrame.Characters.Text = "L"
lamb.TextFrame.Characters.Font.ColorIndex = 1
With lamb.TextFrame.Characters(1, 1)
End With
End Sub



Sub add_apple()
Dim apple As Shape
Dim ws As Worksheet
Dim iNumapple As Variant
Dim i As Long
iNumapple = InputBox("How many apple? ")
If Len(iNumapple) = 0 Or iNumapple < 1 Then Exit Sub
Sheets(1).Select
Range(Cells(1, 1), Cells(1000, 100)).Clear 'this should apply to the shapes not cells
With Worksheets("Sheet1")
For i = 1 To iNumapple
.Cells(11, 2 + i).Value = "A" & i
If Not .Cells(11, 2 + i).Value = "" Then
.Cells(11, 2 + i).Interior.Color = RGB(100, 255, 100)
End If
Next i
End With
Set ws = ActiveSheet
Set apple = ws.Shapes.AddShape(9, 250, 45, 30, 30)
apple.Fill.ForeColor.RGB = RGB(225, 100, 100)
apple.TextFrame.Characters.Text = "A"
apple.TextFrame.Characters.Font.ColorIndex = 1
With apple.TextFrame.Characters(1, 1)
End With
End Sub



Sub add_man()
Dim man As Shape
Dim ws As Worksheet
Dim iNumman As Variant
Dim i As Long
iNumman = InputBox("How many man? ")
If Len(iNumman) = 0 Or iNumman < 1 Then Exit Sub
Sheets(1).Select
Range(Cells(1, 1), Cells(1000, 100)).Clear 'this should apply to the shapes not cells
With Worksheets("Sheet1")
For i = 1 To iNumman
.Cells(15, 2 + i).Value = "M" & i
If Not .Cells(11, 2 + i).Value = "" Then
.Cells(15, 2 + i).Interior.Color = RGB(0, 255, 0)
End If
Next i
End With
Set ws = ActiveSheet
Set man = ws.Shapes.AddShape(17, 300, 45, 40, 30)
man.Fill.ForeColor.RGB = RGB(100, 225, 100)
man.TextFrame.Characters.Text = "M"
man.TextFrame.Characters.Font.ColorIndex = 1
With man.TextFrame.Characters(1, 1)
End With
End Sub


I have three sub procedures each for lamb, apple and man. And I have three buttons on the worksheet which i assigned to each procedure

Clicking on individual button should be independent of each other.
For example clicking on lamb button should do the following
-Ask how many lamb?
-type in number of lambs
-corresponding number of lambs -should appear cascaded on each other with textnumber of lamb enter with assigned colour code and shape
-and the shape should be able to move around the sheet to any location

The same applys to other two, with affecting each other (I have problem with this I guess because they are all on the same activesheet)

I managed to do the counting (L1, L2, ....) on the cell but should be with the individual shape type which correspond to the three objects

Thanks in anticipation for you help.

mana
11-05-2016, 06:55 PM
Option Explicit

Sub add_lamb()
Dim sp As Shape
Dim ws As Worksheet
Dim n, i As Long

n = Application.InputBox("How many lamb ? ", Type:=1)
If VarType(n) = vbBoolean Then Exit Sub

Set ws = ActiveSheet

For Each sp In ws.Shapes
If sp.Name = "lamb" Then sp.Delete
Next
ws.Rows(8).Clear

For i = 1 To n
ws.Cells(8, 2 + i).Value = "L" & i
If Not ws.Cells(11, 2 + i).Value = "" Then
ws.Cells(8, 2 + i).Interior.Color = RGB(100, 200, 255)
End If

With ws.Shapes.AddShape(1, 160 + i * 40, 55, 40, 20)
.Name = "lamb"
.Fill.ForeColor.RGB = RGB(100, 200, 255)
.TextFrame.Characters.Text = "L"
.TextFrame.Characters.Font.ColorIndex = 1
End With

Next

End Sub

victor222
11-07-2016, 06:55 AM
Hello mana,

Oh thank you very much for this....really works!

Regards