Codice esteso all'uso di 5 checkbox

Question

Codice esteso all'uso di 5 checkbox

Anonimo

Ciao a tutti,

Ho bisogno ancora di voi per avere la possibilità di aggiungere all'ottimo codice preparato da Norma l'uso di 5 checkbox. Ho provato da solo ma sono riuscito solo nell'inserimento dei vaori. Quello che chiedo è di avere la possibilità di poter intervenire anche sul button cbModifica e visualizzare anche nella listbox i valori delle checkbox. Le 5 checkbox sono state inserite nella frame2 e la parte aggiunta nel codice di Norman che vedete in grassetto è quello che dovrebbero fare.

Option Explicit

Dim lRiga As Long

Private bStopEvents As Boolean

'--------->>

Private Sub cbNuovo_Click()

Call mPulisciTextBox

End Sub

'--------->>

Private Sub mPulisciTextBox()

Dim Ctl As MsForms.control

bStopEvents = True

For Each Ctl In Me.Controls

If TypeOf Ctl Is MsForms.TextBox _

Or TypeOf Ctl Is MsForms.ComboBox Then

Ctl.Value = vbNullString

End If

Next Ctl

bStopEvents = False

End Sub

'--------->>

Private Sub cbInserisci_Click()

Dim sortRng As Range

Dim strNominativo As String, strIndirizzo As String, strEmail As String

Dim strLuogo As String, strGruppo As String, strStato As String

Dim strTelFisso As String, strCellulare As String

Dim strNascita As String, strRegistrazione As String

Dim arrNuovoRecord As Variant

Dim iCols As Long

Const sStr As String = "X"

On Error GoTo XIT

Application.EnableEvents = False

With Me

strNominativo = .tbNome.Value

strIndirizzo = .tbIndirizzo.Value

strEmail = .tbEmail.Value

strLuogo = .tbLuogoNascita.Value

strNascita = tbDataNascita.Text

strGruppo = .cbxResponsabileGruppo.Value

strStato = .cbxCondizioneSprituale.Value

strRegistrazione = .tbDataRegistrazione.Value

strTelFisso = .tbTelefonoFisso.Value

strCellulare = .tbCellulare.Value

arrNuovoRecord = VBA.Array(strNominativo, strIndirizzo, _

strEmail, strLuogo, _

strNascita, strGruppo, _

strStato, strTelFisso, _

strCellulare)

End With

With mainSH

lRiga = .Range("A" & .Rows.Count).End(xlUp).Row

iCols = UBound(arrNuovoRecord) + 1

.Range("A" & lRiga + 1).Resize(1, iCols).Value _

= arrNuovoRecord

Set sortRng = .Range("A3:A" & lRiga + 1).Resize(, iCols)

If Me.Chkma.Value = True Then

.Range("K" & lRiga + 1).Value = sStr

Else

Me.Chkma.Value = vbNullString

End If

If Me.Chkfe.Value = True Then

.Range("L" & lRiga + 1).Value = sStr

Else

Me.Chkfe.Value = vbNullString

End If

If Me.Chkan.Value = True Then

.Range("M" & lRiga + 1).Value = sStr

Else

Me.Chkan.Value = vbNullString

End If

If Me.Chkse.Value = True Then

.Range("N" & lRiga + 1).Value = sStr

Else

Me.Chkse.Value = vbNullString

End If

If Me.Chkpi.Value = True Then

.Range("O" & lRiga + 1).Value = sStr

Else

Me.Chkse.Value = vbNullString

End If

End With

Call OrdinaRighe(mainSH, sortRng)

Call AggiornaFogliMensili2(arrNuovoRecord)

Call mCaricaListBox

XIT:

Application.EnableEvents = True

End Sub

'--------->>

Private Sub cbModifica_Click()

Dim strIndirizzo As String, strEmail As String

Dim strLuogo As String, strGruppo As String, strStato As String

Dim strTelFisso As String, strCellulare As String

Dim strNascita As String, strRegistrazione As String

Dim strMsg As String, strTitle As String

Dim iButtons As VbMsgBoxResult

Dim arrModificaRecord As Variant

Dim lng As Long, UB As Long

On Error GoTo RigaErrore

If Me.ListBox1.ListIndex = -1 Then

Err.Raise 381

End If

With Me

strIndirizzo = .tbIndirizzo.Value

strEmail = .tbEmail.Value

strLuogo = .tbLuogoNascita.Value

strNascita = .tbDataNascita.Value

strGruppo = .cbxResponsabileGruppo.Value

strStato = .cbxCondizioneSprituale.Value

strRegistrazione = .tbDataRegistrazione.Text

strTelFisso = .tbTelefonoFisso.Value

strCellulare = .tbCellulare.Value

End With

With mainSH

For lng = 3 To lRiga

If .Range("A" & lng).Value = _

Me.ListBox1.List(Me.ListBox1.ListIndex, 0) Then

arrModificaRecord = VBA.Array(strIndirizzo, _

strEmail, strLuogo, _

strNascita, strGruppo, _

strStato, strTelFisso, _

strCellulare)

UB = UBound(arrModificaRecord)

.Range("B" & lng).Resize(1, UB + 1).Value = arrModificaRecord

Exit For

End If

RigaChiusura:

Call mCaricaListBox

Exit Sub

RigaErrore:

If Err.Number = 381 Then

strMsg = "Selezionare il nome da modificare"

iButtons = vbOKOnly + vbInformation

strTitle = "Attenzione"

Else

strMsg = Err.Number _

& vbNewLine _

& Err.Description

iButtons = vbCritical

strTitle = "ERRORE"

End If

Call MsgBox(Prompt:=strMsg, _

Buttons:=iButtons, _

Title:=strTitle)

Resume RigaChiusura

End Sub

Grazie come sempre per la vostra attenzione

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

4 risposte aggiuntive

Answer 1

Ciao Geacs,

Nel modulo di codice mAggiornaFogliMensili, sostituisci il codice con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub InitVars()

Set mainSH = ThisWorkbook.Worksheets(mainSheetName)

arrMese = Application.GetCustomListContents(4)

bVarsOK = True

End Sub

'--------->>

Public Sub OrdinaRighe(aSH As Worksheet, theRng As Range)

Application.ScreenUpdating = False

If Not bVarsOK Then Call InitVars

With aSH

.Sort.SortFields.Clear

.Sort.SortFields.Add Key:=theRng.Columns(1) _

, SortOn:=xlSortOnValues, _

Order:=xlAscending, _

DataOption:=xlSortNormal

With .Sort

.SetRange theRng

.Header = xlNo

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

XIT:

Application.ScreenUpdating = True

End Sub

'--------->>

Public Sub AggiornaFogliMensili(strOld As String, strNew As String)

Dim WB As Workbook

Dim SH As Worksheet

Dim searchRng As Range, foundRng As Range

Dim Res As Variant

Dim Lrow As Long

Const sPassword As String = "abcVba"

If Not bVarsOK Then Call InitVars

Set WB = ThisWorkbook

For Each SH In WB.Sheets(arrMese)

With SH

Lrow = .Range("B" & .Rows.Count).End(xlUp).Row

Set searchRng = .Range("B10:B" & Lrow)

Set foundRng = searchRng.Find(What:=strOld, _

LookIn:=xlValues, _

LookAt:=xlWhole, _

SearchOrder:=xlByRows, _

SearchDirection:=xlNext, _

MatchCase:=False)

If Not foundRng Is Nothing Then

foundRng.Value = strNew

Call OrdinaRighe(SH, searchRng.Resize(, 9))

Else

Call MsgBox(Prompt:="Il record per " _

& strOld _

& "non e' stato trovato!" _

& vbNewLine & vbNewLine _

& "Contatta Geacs!", _

Buttons:=vbCritical, _

Title:="GRANDE PROBLEMA!")

End If

End With

Next SH

End Sub

'--------->>

Public Sub AggiornaFogliMensili2(arrDati As Variant)

Dim WB As Workbook

Dim SH As Worksheet

Dim destRng As Range, sortRng As Range

Dim Res As Variant

Dim Lrow As Long

Const sPassword As String = "abcVba"

If Not bVarsOK Then InitVars

Set WB = ThisWorkbook

For Each SH In WB.Sheets(arrMese)

With SH

Lrow = .Range("B" & .Rows.Count).End(xlUp).Row

Set sortRng = .Range("B10:J" & Lrow + 1)

Set destRng = .Range("B" & Lrow + 1)

destRng.Value = arrDati

Call OrdinaRighe(SH, sortRng)

End With

Next SH

End Sub

'<<=========

Nel modulo di codice della tua Userform Congregazione, sostituisci il codice precedente con la seguente versione:

'=========>>

Option Explicit

Dim lRiga As Long

Private bStopEvents As Boolean

Private Const sStr As String = "X"

'--------->>

Private Sub cbNuovo_Click()

Call mPulisciTextBox

End Sub

'--------->>

Private Sub mPulisciTextBox()

Dim Ctl As MsForms.control

bStopEvents = True

For Each Ctl In Me.Controls

If TypeOf Ctl Is MsForms.TextBox _

Or TypeOf Ctl Is MsForms.ComboBox Then

Ctl.Value = vbNullString

ElseIf TypeOf Ctl Is MsForms.CheckBox Then

Ctl.Value = False

End If

Next Ctl

bStopEvents = False

End Sub

'--------->>

Private Sub cbInserisci_Click()

Dim sortRng As Range

Dim strNominativo As String, strIndirizzo As String, strEmail As String

Dim strLuogo As String, strGruppo As String, strStato As String

Dim strTelFisso As String, strCellulare As String

Dim strNascita As String, strRegistrazione As String

Dim arrNuovoRecord As Variant

Dim iCols As Long, i As Long

Dim bDati As Boolean

On Error GoTo XIT

Application.EnableEvents = False

With Me

strNominativo = .tbNome.Value

strIndirizzo = .tbIndirizzo.Value

strEmail = .tbEmail.Value

strLuogo = .tbLuogoNascita.Value

strNascita = tbDataNascita.Text

strGruppo = .cbxResponsabileGruppo.Value

strStato = .cbxCondizioneSprituale.Value

strRegistrazione = .tbDataRegistrazione.Value

strTelFisso = .tbTelefonoFisso.Value

strCellulare = .tbCellulare.Value

arrNuovoRecord = VBA.Array(strNominativo, strIndirizzo, _

strEmail, strLuogo, _

strNascita, strGruppo, _

strStato, strTelFisso, _

strCellulare)

End With

For i = LBound(arrNuovoRecord) To UBound(arrNuovoRecord)

bDati = arrNuovoRecord(i) <> vbNullString

If bDati Then

Exit For

End If

Next i

If Not bDati Then

Call MsgBox(Prompt:="Non hai inserito qualsiasi dato per un nuovo record!", _

Buttons:=vbCritical, _

Title:="NUOVO RECORD CANCELLATO!")

Call mPulisciTextBox

Exit Sub

End If

With mainSH

lRiga = .Range("A" & .Rows.Count).End(xlUp).Row

iCols = UBound(arrNuovoRecord) + 1

.Range("A" & lRiga + 1).Resize(1, iCols).Value _

= arrNuovoRecord

Set sortRng = .Range("A3:A" & lRiga + 1).Resize(, iCols + 5)

End With

Call AggiornaValoriX(lRiga + 1)

Call OrdinaRighe(mainSH, sortRng)

Call AggiornaFogliMensili2(arrNuovoRecord)

Call mCaricaListBox

XIT:

Application.EnableEvents = True

End Sub

'--------->>

Private Sub cbModifica_Click()

Dim strIndirizzo As String, strEmail As String

Dim strLuogo As String, strGruppo As String, strStato As String

Dim strTelFisso As String, strCellulare As String

Dim strNascita As String, strRegistrazione As String

Dim strMsg As String, strTitle As String

Dim iButtons As VbMsgBoxResult

Dim arrModificaRecord As Variant, arrCheckBox As Variant

Dim lng As Long, UB As Long

Dim myIndex As Long

Dim bStop As Boolean

On Error GoTo RigaErrore

myIndex = Me.ListBox1.ListIndex

If myIndex = -1 Then

bStop = True

Err.Raise 381

End If

With Me

strIndirizzo = .tbIndirizzo.Value

strEmail = .tbEmail.Value

strLuogo = .tbLuogoNascita.Value

strNascita = .tbDataNascita.Value

strGruppo = .cbxResponsabileGruppo.Value

strStato = .cbxCondizioneSprituale.Value

strRegistrazione = .tbDataRegistrazione.Text

strTelFisso = .tbTelefonoFisso.Value

strCellulare = .tbCellulare.Value

End With

With mainSH

For lng = 3 To lRiga

If .Range("A" & lng).Value = _

Me.ListBox1.List(Me.ListBox1.ListIndex, 0) Then

arrModificaRecord = VBA.Array(strIndirizzo, _

strEmail, strLuogo, _

strNascita, strGruppo, _

strStato, strTelFisso, _

strCellulare)

UB = UBound(arrModificaRecord)

.Range("B" & lng).Resize(1, UB + 1).Value = arrModificaRecord

Call AggiornaValoriX(lng)

Exit For

End If

RigaChiusura:

If Not bStop Then

Call mCaricaListBox(myIndex)

End If

Exit Sub

RigaErrore:

If Err.Number = 381 Then

strMsg = "Selezionare il nome da modificare"

iButtons = vbOKOnly + vbInformation

strTitle = "Attenzione"

Else

strMsg = Err.Number _

& vbNewLine _

& Err.Description

iButtons = vbCritical

strTitle = "ERRORE"

End If

Call MsgBox(Prompt:=strMsg, _

Buttons:=iButtons, _

Title:=strTitle)

Resume RigaChiusura

End Sub

'--------->>

Private Sub cbElimina_Click()

Dim lng As Long

Dim lRisposta As Long

Dim SH As Worksheet

Dim rngFound As Range

Dim sStr As String, strMsg As String, strTitle As String

Dim strNome As String

Dim iButtons As VbMsgBoxResult

On Error GoTo RigaErrore

If Me.ListBox1.ListIndex = -1 Then

Err.Raise 381

End If

Application.EnableEvents = False

With Me.ListBox1

strNome = .List(.ListIndex)

End With

lRisposta = MsgBox(Prompt:="Eliminare il nome selezionato:" _

& vbNewLine _

& vbTab & strNome & " ?", _

Buttons:=vbYesNo + vbQuestion, _

Title:="Attenzione")

If lRisposta = vbYes Then

With mainSH

For lng = lRiga To 3 Step -1

If .Range("A" & lng).Value = _

Me.ListBox1.List(Me.ListBox1.ListIndex, 0) Then

sStr = .Range("A" & lng).Value

.Rows(lng).EntireRow.Delete

For Each SH In Worksheets(arrMese)

With SH

Set rngFound = SH.Columns(2).Find(What:=sStr, _

After:=SH.Range("B2"), _

LookIn:=xlValues, _

SearchOrder:=xlRows, _

SearchDirection:=xlNext, _

MatchCase:=False)

If Not rngFound Is Nothing Then

rngFound.EntireRow.Delete

End If

End With

Next SH

Exit For

End If

Call mCaricaListBox

Call mPulisciTextBox

End If

RigaChiusura:

Application.EnableEvents = True

Exit Sub

RigaErrore:

If Err.Number = 381 Then

strMsg = "Selezionare la riga da eliminare"

iButtons = vbOKOnly + vbInformation

strTitle = "Attenzione"

Else

strMsg = Err.Number & vbNewLine & Err.Description

iButtons = vbCritical

strTitle = "Errore"

End If

Call MsgBox(Prompt:=strMsg, Buttons:=iButtons, Title:=strTitle)

Resume RigaChiusura

End Sub

'--------->>

Private Sub cbArchivia_Click()

Call Inattivi

End Sub

'--------->>

Private Sub ListBox1_Click()

With Me

.tbNome.Value = .ListBox1.List(.ListBox1.ListIndex, 0)

.tbIndirizzo.Text = .ListBox1.List(.ListBox1.ListIndex, 1)

.tbEmail.Text = .ListBox1.List(.ListBox1.ListIndex, 2)

.tbLuogoNascita.Text = .ListBox1.List(.ListBox1.ListIndex, 3)

.tbDataNascita.Text = .ListBox1.List(.ListBox1.ListIndex, 4)

.cbxResponsabileGruppo.Text = .ListBox1.List(.ListBox1.ListIndex, 5)

.cbxCondizioneSprituale.Text = .ListBox1.List(.ListBox1.ListIndex, 6)

.tbDataRegistrazione.Text = "31/12/2000"

.tbTelefonoFisso.Text = .ListBox1.List(.ListBox1.ListIndex, 7)

.tbCellulare.Text = .ListBox1.List(.ListBox1.ListIndex, 8)

.Chkma.Value = .ListBox1.List(.ListBox1.ListIndex, 10) = sStr

.Chkfe.Value = .ListBox1.List(.ListBox1.ListIndex, 11) = sStr

.Chkan.Value = .ListBox1.List(.ListBox1.ListIndex, 12) = sStr

.Chkse.Value = .ListBox1.List(.ListBox1.ListIndex, 13) = sStr

.Chkpi.Value = .ListBox1.List(.ListBox1.ListIndex, 14) = sStr

End With

End Sub

'--------->>

Private Sub tbNome_Change()

If bStopEvents Then Exit Sub

tbNome.Value = Application.Proper(tbNome.Text)

End Sub

'--------->>

Private Sub tbIndirizzo_Change()

If bStopEvents Then Exit Sub

tbIndirizzo.Value = Application.Proper(tbIndirizzo.Text)

End Sub

'--------->>

Private Sub tbLuogoNascita_Change()

If bStopEvents Then Exit Sub

tbLuogoNascita.Value = Application.Proper(tbLuogoNascita.Text)

End Sub

'--------->>

Private Sub UserForm_Initialize()

With Me.ListBox1

.ColumnCount = 15

.ColumnWidths = "90;130;120;70;70;50;90;85;85;0;12;12;12;12;12"

End With

With Me.cbxCondizioneSprituale

.AddItem "Componente regolare"

.AddItem "Inattivo"

End With

Call mCaricaListBox

End Sub

'--------->>

Private Sub mCaricaListBox(Optional iIndex As Variant)

Dim lng As Long

Dim lCont As Long

Dim Rng As Range

Dim arrIn As Variant

lCont = 0

If Not bVarsOK Then Call InitVars

With mainSH

Me.ListBox1.Clear

lRiga = .Range("A" & .Rows.Count).End(xlUp).Row

Set Rng = .Range("A3:O" & lRiga)

Me.ListBox1.List = Rng.Value

End With

If Not IsMissing(iIndex) Then

Me.ListBox1.Selected(iIndex) = True

End If

End Sub

Private Sub AggiornaValoriX(iRow As Long)

Dim SH As Worksheet

If Not bVarsOK Then Call InitVars

On Error GoTo XIT

Application.EnableEvents = False

With mainSH

If Me.Chkma.Value = True Then

.Range("K" & iRow).Value = sStr

Else

.Range("K" & iRow).ClearContents

End If

If Me.Chkfe.Value = True Then

.Range("L" & iRow).Value = sStr

Else

.Range("L" & iRow).ClearContents

End If

If Me.Chkan.Value = True Then

.Range("M" & iRow).Value = sStr

Else

.Range("M" & iRow).ClearContents

End If

If Me.Chkse.Value = True Then

.Range("N" & iRow).Value = sStr

Else

.Range("N" & iRow).ClearContents

End If

If Me.Chkpi.Value = True Then

.Range("O" & iRow).Value = sStr

Else

.Range("O" & iRow).ClearContents

End If

End With

XIT:

Application.EnableEvents = True

End Sub

'<<=========

Potresti scaricare il mio file di prova Geacs20150603.xlsm a: **http://1drv.ms/1Gk6CRO**

===

Regards,

Norman

Answer 2

Anonimo

Ciao Geacs,

Ti ringrazio per il cortese riscontro e mi fa piacere che il codice sia utile.

Per chiudere il thread, ti chiederei di gentilmente segnare la risposta rilevante come Risposta.

Alla prossima.

===

Regards,

Norman

0 commenti

Answer 3

Ciao Norman,

Sei Grande hai fatto esattamente quello che ti avevo chiesto. Adesso lavorare con questo schema diventa una passeggiata senza il rischio di dimenticare qualcosa. Riesci a trasformare quello che sta nella nostra mente che a volte troviamo difficile anche spiegare. Ti ringrazio ancora per tutto quello che mi hai dato.

Answer 4

Ciao Norman e grazie della rapida risposta,

I valori delle checkbox sono un'estensione dei valori che vengono riportati solo nel foglio1 escludendo i fogli mensili. Pertanto come visualizzo i valori nominativo, indirizzo e altro ho bisogno di visualizzare anche i valori (X) inseriti mediante checkbox.
Lo scopo di questi valori inseriti mediante checkbox nel foglio1 è quello di richiamarle mediante la formula cercavert su un foglio che non ha nulla a che fare con il foglio1. Con tutta sincerità prima di questo momento le inserivo manualmente intervenendo sul foglio1. Riflettendo mi sono reso conto che posso semplificare il tutto nel momento che registro i vari nominativi spuntando la checkbox interessata. Pertanto non devono essere nascoste o disattivate.
Infine quando avviene una modifica al record ad esempio il nominativo che era stato registrato spuntando la la checkbox denominata chkan adesso mi si presenta la necessità di togliere la spunta (X). Spero di essermi spiegato dandoti la possibilità di capire lo scopo di questo intervento.

Answer 5

Ciao Geacs.

Temo che io non abbia ben capito la tua esigenza o lo scopo delle CheckBox.

Pertanto, ti chiedo, per favore, di confermare se i valori delle CheckBox dovrebbero essere visualizzati in ListBox1 solo quando il pulsante cbModifica sia premuto e che, più in particolare, se un nuovo record sia successivamente inserito, i valori delle CheckBox non devono essere visualizzati nel controllo ListBox?

Proprio perché questo mi parrebbe un comportamento strano, penso che sarebbe opportuno spiegare lo scopo e il funzionamento delle CheckBox in modo più dettagliato. Forse, per esempio, a determinate condizioni, le CheckBox potrebbero essere disattivate o nascoste?

Inoltre, potresti confermare che quando un record viene modificato, i corrispondenti valori nelle colonne K:O dovrebbero essere inseriti nei fogli mensili?

La manipolazione e la modifica del codice non rappresenta una difficoltà; il mio problema è quello di capire le tue esigenze.

===

Regards,

Norman

Condividi tramite

Codice esteso all'uso di 5 checkbox

4 risposte aggiuntive