Ciao Roberto,
Post by RobertoDevo inserire i risultati di un questionario cartaceo in un foglio Excel. E'
possibile inserire pulsanti cliccando sui quali si incrementi di una unità il
valore di una cella vicina? Grazie!
Prova ad incollarci il seguente codice in un modulo standard:
'=============>>
Public Sub AddButtons()
Dim wb As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim rcell As Range
Dim BTN As Button
Dim iTop As Long
Dim iLeft As Long
Dim iHeight As Long
Dim iWidth As Long
Const sStr As String = "myAdd"
Const sStr2 As String = "mySubtract"
Set wb = Workbooks("Cartella1.xls") '<<=== da CAMBIARE
Set SH = wb.Sheets("Foglio1") '<<=== da CAMBIARE
Set Rng = SH.Range("B2:B20") '<<=== da CAMBIARE
With Rng
.Resize(1, 3).Offset(0, 1).EntireColumn.Insert
.Resize(1, 4).ColumnWidth = 3
.Offset(0, 2).Interior.ColorIndex = 6
For Each rcell In .Offset(0, 1).Cells
With rcell
iLeft = .Left
iTop = .Top
iWidth = .Width
iHeight = .Height
Set BTN = SH.Buttons.Add(iLeft, _
iTop, iWidth, iHeight)
BTN.OnAction = sStr
BTN.Caption = "+"
End With
Next rcell
For Each rcell In .Offset(0, 3).Cells
With rcell
iLeft = .Left
iTop = .Top
iWidth = .Width
iHeight = .Height
Set BTN = SH.Buttons.Add(iLeft, _
iTop, iWidth, iHeight)
BTN.OnAction = sStr2
BTN.Caption = "-"
End With
Next rcell
End With
End Sub
'------------------>
Public Sub myAdd()
Dim BTN As Button
Dim DoveSono As String
Dim Rng As Range
Set BTN = ActiveSheet.Buttons(Application.Caller)
DoveSono = BTN.TopLeftCell.Address
Set Rng = Range(DoveSono).Offset(0, -1)
With Rng
If IsNumeric(.Value) Then
.Value = .Value + 1
End If
End With
End Sub
'------------------>
Public Sub mySubtract()
Dim BTN As Button
Dim DoveSono As String
Dim Rng As Range
Set BTN = ActiveSheet.Buttons(Application.Caller)
DoveSono = BTN.TopLeftCell.Address
Set Rng = Range(DoveSono).Offset(0, -2)
With Rng
If IsNumeric(.Value) Then
.Value = .Value - 1
End If
End With
End Sub
'<<=============
Alt-F11 per aprire l'Editor di VBA
Menu | Inserisci | Modulo
Incollarci il suddetom codice
Alt-F11 per tornare in Excel
Alt-F8
Seleziona "AddButtons"
Esegui
Sostituisci:
Set Rng = SH.Range("B2:B20") '<<==== da CAMBIARE
con il tuo range per i risultati incrementati del questionario.
---
Regards,
Norman