EXCEL VBA SHAPE OBJECT, BUTTON, WORKSHEET HELP

[victor222]

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]

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]

Hello mana,

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

Regards