Excel Vba Appello anagrafica a mezzo InputBox

Question

Buon Giorno

In un Foglio Excel ho una tabella con nella colonna  A  un elenco di nominativi  ( A2  fino  A196 )

Nella colonna   B   (B2  fino  B196 )  devo inserire   P  (presente) oppure  A  (assente)

Ho  creato  una UserForm   e  pensavo di utilizzare le InputBox

La procedura parte   tramite commandButton  (cbInizia)   che apre l’InputBox  nel quale digitare P  oppure A

Il dato inserito viene inserito nella cella B2 del Foglio1 

Questa la parte di codice che utilizzo

Private Sub cbInizia_Click()

 Dim i As Long

 Dim wk1 As Workbook

 Dim sh1 As Worksheet

 Dim Message1, Title1, MyValue1

Set wk1 = ThisWorkbook

Set sh1 = wk1.Worksheets("Foglio1")

10

Message1 = "COGNOME NOME 1:"

Title1 = "APPELLO NOMINATIVI"

MyValue1 = InputBox(Message1, Title1)

If MyValue1 <> "" Then

i = 2

With sh1

Sheets("Foglio1").Cells(2, i).Value = MyValue1

End With

End Sub

Mi sono bloccato perche’ era evidente che con questo sistema avrei dovuto ripetere questa procedura per

196 volte …….!!

Chiedo aiuto per sapere come posso far si che :

Message1 (Cognome Nome )  anziche’ essere digitato nel codice sia caricato direttamente dalla tabella , cioe’  l’InputBox1 all’apertura presenti il Nominativo presente in A1 , l’InputBox2  quello in A2  etc ….fino a A196

Non padroneggio i cicli Nexth For ..... pero' posso impegnarmi , volevo solo un'indicazione e capire se quello che vorrei fare e' fattibile

                        Grazie      Claudio P

Answer 1

Ciao Claudio,

In un Foglio Excel ho una tabella con nella colonna  A  un elenco di nominativi  ( A2  fino  A196 )

 

Nella colonna   B   (B2  fino  B196 )  devo inserire   P  (presente) oppure  A  (assente)

 

Ho  creato  una UserForm   e  pensavo di utilizzare le InputBox

 

La procedura parte   tramite commandButton  (cbInizia)   che apre l’InputBox  nel quale digitare P  oppure A

Il dato inserito viene inserito nella cella B2 del Foglio1 

 

Questa la parte di codice che utilizzo

Private Sub cbInizia_Click()

 Dim i As Long

 Dim wk1 As Workbook

 Dim sh1 As Worksheet

 Dim Message1, Title1, MyValue1

 

Set wk1 = ThisWorkbook

Set sh1 = wk1.Worksheets("Foglio1")

10

Message1 = "COGNOME NOME 1:"

Title1 = "APPELLO NOMINATIVI"

MyValue1 = InputBox(Message1, Title1)

 

If MyValue1 <> "" Then

i = 2

With sh1

Sheets("Foglio1").Cells(2, i).Value = MyValue1

End With

End Sub

 

Mi sono bloccato perche’ era evidente che con questo sistema avrei dovuto ripetere questa procedura per

196 volte …….!!

 

Chiedo aiuto per sapere come posso far si che :

Message1 (Cognome Nome )  anziche’ essere digitato nel codice sia caricato direttamente dalla tabella , cioe’  l’InputBox1 all’apertura presenti il Nominativo presente in A1 , l’InputBox2  quello in A2  etc ….fino a A196

Non padroneggio i cicli Nexth For ..... pero' posso impegnarmi , volevo solo un'indicazione e capire se quello che vorrei fare e' fattibile

Vorrei suggerire un approccio diverso!

Quindi, per dimostrarlo, crea una Userform con i seguenti controlli:

• un Listbox  denominato lbxNominativi
• un TextBox denominato tbxPresenza
• un CommandButton denominato cbAggiornaRecord
• un CommandButton denominato cbEsci

Nel modulo di codice della Userform, incolla codice del genere:

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

Option Explicit

Dim SH As Worksheet

Dim Rng As Range

Dim arr As Variant

Private bEvents As Boolean

Private Sub lbxNominativi_Change()

    With Me.lbxNominativi

        Me.tbxPresenza.Value = .List(.ListIndex, 1)

    End With

End Sub

Private Sub tbxPresenza_Change()

    With Me.tbxPresenza

        .Text = UCase(.Text)

    End With

End Sub

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

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Const sFoglio As String = "Foglio1"           '<<=== Modifica

    Const sTabella As String = "A1:B27"         '<<=== Modifica 

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH.Range(sTabella)

        Set Rng = .Offset(1).Resize(.Rows.Count - 1)

    End With

    With Me

        .cbAggiornaRecord.Caption = "Aggiorna record"

        .cbEsci.Caption = "ESCI"

        With .lbxNominativi

            .List = Rng.Value

        End With

    End With

End Sub

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

Private Sub cbAggiornaRecord_Click()

    With Me.lbxNominativi

        bEvents = False

        Rng.Cells(.ListIndex + 1, 2).Value = Me.tbxPresenza.Value

        .List = Rng.Value

        bEvents = True

    End With

End Sub

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

Private Sub cbEsci_Click()

    Unload Me

End Sub

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

Potresti scaricare il mio file di prova Claudio20180418.xlsm

===

Regards,

Norman

Answer 2

Ciao Claudio,

Rispondo molto tardivamente perché sono stato in viaggio negli ultimi giorni.

Peccato che non sia possibile ,  ... le InputBox  davano la possibilita' di eseguire l'appello dietro domanda in maniera sequenziale partendo in ordine Alfabetico ... mi sembrava esteticamente piu' bello .... 

Io, da un perspettivo personale, non vedo nulla di intrinsecamente bello o efficace nell'uso delle  InputBox per la tua esigenza. 

Comunque, per gestire la possibilità che i dati sul foglio non fossero in ordina alfabetico crescente e per presentarli ordinati nel controllo ListBox, prova qualcosa del seguente genere:

Nel modulo di codice della Userform, incolla

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

Option Explicit

Dim SH As Worksheet

Dim Rng As Range

Dim arrDati() As Variant

Private bEvents As Boolean

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

Private Sub lbxNominativi_Change()

    If bEvents = False Then Exit Sub

    bEvents = False

    With Me.lbxNominativi

        Me.tbxPresenza.Value = .List(.ListIndex, 1)

    End With

    bEvents = True

End Sub

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

Private Sub tbxPresenza_Change()

    If bEvents = False Then Exit Sub

    With Me.tbxPresenza

        bEvents = False

        .Text = UCase(.Text)

        bEvents = True

    End With

End Sub

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

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Dim arrIn As Variant

    Dim i As Long, j As Long, iRow As Long

    Const sFoglio As String = "Foglio1"                  '<<=== Modifica

    Const sTabella As String = "A1:B27" '<<=== Modifica

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH.Range(sTabella)

        iRow = .Rows.Count - 1

        Set Rng = .Offset(1).Resize(iRow)

    End With

    arrIn = Rng.Value

    ReDim arrDati(1 To iRow, 1 To 3)

    For i = 1 To iRow

        arrDati(i, 1) = arrIn(i, 1)

        arrDati(i, 2) = arrIn(i, 2)

        arrDati(i, 3) = i

    Next i

    QuickSort arrDati, 1, 1, iRow, True

    With Me

        .cbAggiornaRecord.Caption = "Aggiorna record"

        .cbEsci.Caption = "ESCI"

        With .lbxNominativi

            .List = arrDati

        End With

    End With

    bEvents = True

End Sub

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

Private Sub cbAggiornaRecord_Click()

    Dim sStr As String

    sStr = Me.tbxPresenza.Value

    With Me.lbxNominativi

        bEvents = False

        Rng.Cells(.List(.ListIndex, 2), 2).Value = sStr

        arrDati(.ListIndex + 1, 2) = sStr

        .List = arrDati

        bEvents = True

    End With

End Sub

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

Private Sub cbEsci_Click()

    Unload Me

End Sub

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

In un modulo standard, incolla:

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

Option Explicit

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

Public Sub DisplayUserform()

    UserForm1.Show

End Sub

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

Public Sub QuickSort(SortArray, col, L, R, bAscending)

'\ TomOgilvy: http://goo.gl/ninpZW

'Originally Posted by Jim Rech 10/20/98 Excel.Programming

'Modified to sort on first column of a two dimensional array

'Modified to handle a second dimension greater than 1 (or zero)

'Modified to do Ascending or Descending

    Dim i, j, X, Y, mm

    i = L

    j = R

    X = SortArray((L + R) / 2, col)

    If bAscending Then

        While (i <= j)

            While (SortArray(i, col) < X And i < R)

                i = i + 1

            Wend

            While (X < SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    Else

        While (i <= j)

            While (SortArray(i, col) > X And i < R)

                i = i + 1

            Wend

            While (X > SortArray(j, col) And j > L)

                j = j - 1

            Wend

            If (i <= j) Then

                For mm = LBound(SortArray, 2) To UBound(SortArray, 2)

                    Y = SortArray(i, mm)

                    SortArray(i, mm) = SortArray(j, mm)

                    SortArray(j, mm) = Y

                Next mm

                i = i + 1

                j = j - 1

            End If

        Wend

    End If

    If (L < j) Then Call QuickSort(SortArray, col, L, j, bAscending)

    If (i < R) Then Call QuickSort(SortArray, col, i, R, bAscending)

End Sub

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

Con questa versione del codice, avviando la Userform, vedo qulcosa del genere:

 

Ho aggiornato il mio file di prova  Claudio20180418.xlsm

Io nel frattempo avevo comunque cercato una strada alternativa  e ho provato con  2 TextBox

tbRiga

tbNominativo

la prima carica il Nr. della Riga ( foglio appoggio dove viene copiato il nr presente in una cella appoggio del foglio attivo + 1 )

Option Explicit

Public Sub Apri_()

If Left(ActiveSheet.Name, 7) = "Foglio1" Then

[Z1] = Sheets("Setup").[B1].Value + 1

       Sheets("Setup").[B2] = False

       End If

20

    Dim wk1 As Workbook

    Dim sh1 As Worksheet

    Dim sh2 As Worksheet        

    Set wk1 = ThisWorkbook   

    Set sh1 = wk1.Worksheets("Foglio1")

    Set sh2 = wk1.Worksheets("Setup")

    With sh1      

        .Range("Z1").Copy Destination:=sh2.Range("B1")

    End With                      

    'Set a Nothing delle variabili oggetto

    Set sh2 = Nothing

    Set sh1 = Nothing   

30  

   Appello.Show

End Sub

...........................................

Private Sub cbInizia_Click()

 Dim i As Long

 Dim Rng As Range

 Dim sRiga As String

 Dim sTesto As String

 Dim wk1 As Workbook

 Dim sh1 As Worksheet

 Dim sh2 As Worksheet

Set wk1 = ThisWorkbook

Set sh1 = wk1.Worksheets("Foglio1")

Set sh2 = wk1.Worksheets("Setup")

10

i = 3

  With sh2

  Appello.tbRiga.Value = Sheets("Setup").Cells(1, i).Value

  End With

la seconda carica   il nominativo del nr. riga indicato in tbRiga ( l'ho imparato dai tuoi codici ....)

With Me

        sRiga = .tbRiga.Text

        sTesto = Sheets("Foglio1").Range("A" & sRiga).Value

    End With

Set sh1 = ThisWorkbook.Worksheets("Foglio1")

With sh1

tbNominativo = Sheets("Foglio1").Range("A" & sRiga).Value

End With

Pero' questo mi obbliga a utilizzare 3 commandButton  , Presente, Assente,Delega (e' un'assemblea di condominio ...)

Piu' un commandButton SalvaDati e Continua (passa al nr riga successivo )

Quindi provo con il tuo sistema che e' piu' snello 

Sebbene questo approccio proposto da te non mi sembra efficiente, se il codice suggerito da me non dovesse agire pienamente nel modo desiderato da te, provvederò volentieri alla sua revisione.

===

Regards,

Norman

Answer 3

Grazie  Norman

adesso faccio le prove , ho visto anche la correzzione  (lbx .... )

Peccato che non sia possibile ,  ... le InputBox  davano la possibilita' di eseguire l'appello dietro domanda in maniera sequenziale partendo in ordine Alfabetico ... mi sembrava esteticamente piu' bello .... 

Io nel frattempo avevo comunque cercato una strada alternativa  e ho provato con  2 TextBox

tbRiga

tbNominativo

la prima carica il Nr. della Riga ( foglio appoggio dove viene copiato il nr presente in una cella appoggio del foglio attivo + 1 )

Option Explicit

Public Sub Apri_()

If Left(ActiveSheet.Name, 7) = "Foglio1" Then

[Z1] = Sheets("Setup").[B1].Value + 1

       Sheets("Setup").[B2] = False

       End If

20

    Dim wk1 As Workbook

    Dim sh1 As Worksheet

    Dim sh2 As Worksheet        

    Set wk1 = ThisWorkbook   

    Set sh1 = wk1.Worksheets("Foglio1")

    Set sh2 = wk1.Worksheets("Setup")

    With sh1      

        .Range("Z1").Copy Destination:=sh2.Range("B1")

    End With                      

    'Set a Nothing delle variabili oggetto

    Set sh2 = Nothing

    Set sh1 = Nothing   

30  

   Appello.Show

End Sub

...........................................

Private Sub cbInizia_Click()

 Dim i As Long

 Dim Rng As Range

 Dim sRiga As String

 Dim sTesto As String

 Dim wk1 As Workbook

 Dim sh1 As Worksheet

 Dim sh2 As Worksheet

Set wk1 = ThisWorkbook

Set sh1 = wk1.Worksheets("Foglio1")

Set sh2 = wk1.Worksheets("Setup")

10

i = 3

  With sh2

  Appello.tbRiga.Value = Sheets("Setup").Cells(1, i).Value

  End With

la seconda carica   il nominativo del nr. riga indicato in tbRiga ( l'ho imparato dai tuoi codici ....)

With Me

        sRiga = .tbRiga.Text

        sTesto = Sheets("Foglio1").Range("A" & sRiga).Value

    End With

Set sh1 = ThisWorkbook.Worksheets("Foglio1")

With sh1

tbNominativo = Sheets("Foglio1").Range("A" & sRiga).Value

End With

Pero' questo mi obbliga a utilizzare 3 commandButton  , Presente, Assente,Delega (e' un'assemblea di condominio ...)

Piu' un commandButton SalvaDati e Continua (passa al nr riga successivo )

Quindi provo con il tuo sistema che e' piu' snello

Grazie ancora                 ClaudioP

Answer 4

Ciao Pier Luigi,

segnalo un errore di battitura:

[...]

        With .lbNominativi      '<<======== With .lbxNominativi      

Hai ragione!

Ho ora modificato il codice  che avevo pubblicato ed ho aggiornato il file.

Grazie per la segnalazione.

Alla prossima.

===

Regards,

Norman

Answer 5

Norman buona sera,

segnalo un errore di battitura:

---

Private Sub UserForm_Initialize()

    Dim WB As Workbook

    Const sFoglio As String = "Foglio1"           '<<=== Modifica

    Const sTabella As String = "A1:B27"         '<<=== Modifica 

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH.Range(sTabella)

        Set Rng = .Offset(1).Resize(.Rows.Count - 1)

    End With

    With Me

        .cbAggiornaRecord.Caption = "Aggiorna record"

        .cbEsci.Caption = "ESCI"

        With .lbNominativi      '<<======== With .lbxNominativi

            .List = Rng.Value

        End With

    End With

End Sub

---

Cordiali saluti

Pier Luigi