Userform a schermo pieno

Hai un problema con Excel?

Nuova discussione

Userform a schermo pieno
di Luigi (utente non iscritto) data: 13/11/2017 21:38:56
Buonasera, vorrei ingrandire la userform "frmGestioneDati" a schermo pieno. Ho trovato in rete varie soluzioni ma tutte mi danno lo stesso errore: rilevato nome Univoco: Userform Activate. Certamente è un duplicato, ma non so come uscire da questo impasse. Chiedo scusa se il codice vba è così lungo, im ogni caso qualora fosse necessario allegare il progetto sono qui.
Grazie anticipate

Luigi

Private Sh As Worksheet
Private lUltRiga As Long
Private lRigaAttiva As Long
Private lNuovoID As Long
Private sRicercaDato As String
Private sRicercaCampo As String
Private lRigaValoreTrovato As Long


Private Sub TextBox1_Change()

End Sub

Private Sub opt2_Click()

End Sub

Private Sub txtDataArrivo_Change()

    On Error Resume Next
        x = Len(txtDataArrivo)
        Y = LTrim(txtDataArrivo.Text)
        d = txtDataArrivo
        If d = "" Then
        txtDataArrivo.BackColor = &HFFFFFF
    Exit Sub
End If
    If Left(d, 2) > 31 Then
    MsgBox "Giorno Errato"
        txtDataArrivo.SelStart = 0
        txtDataArrivo.SelLength = Len(txtDataArrivo)
    Exit Sub
End If
    If x = 2 Then txtDataArrivo = Y & "/"
    If x = 4 Then Exit Sub

    If Mid(d, 4, 2) = "" Then Exit Sub
    If Mid(d, 4, 2) > 12 Then 'ora controlliamo che il mese non superi il numero 12, si avvisa, si esce
    MsgBox "Mese Errato"
        txtDataArrivo.SelStart = 3
        txtDataArrivo.SelLength = Len(txtDataArrivo)
    Exit Sub
End If

'--------per rendere completo il sistema di verifica, inseriamo le istruzioni che controllino anche di non superare il 'giorno di fine mese rispetto ai mesi di febbraio e dei mesi a fine 30

    e = Left(d, 2) 'con la variabile "e" prendiamo il giorno della data introdotta
    f = Mid(d, 4, 2) 'con la variabile "f" prendiamo il mese della data introdotta
    Select Case f 'usiamo il Select Case che verificherà il Caso Febbraio (02 in numero)
        Case "02"
            If e > 29 Then GoTo mess 'se il giorno ("e") è maggiore di 29 avvisiamo, selezioniamo e usciamo dalla routine

        Case "04", "06", "09", "11" 'ora si controlla i Case dei mesi di 30 giorni
        If e > 30 Then GoTo mess 'se il giorno ("e") è maggiore di 30 avvisiamo, selezioniamo e usciamo dalla routine
    End Select
    If x = 5 Then
        txtDataArrivo = Y & "/"
    Exit Sub
    End If

    If x = 6 Then Exit Sub
    If x = 7 Then Exit Sub
    If x = 8 Then Exit Sub
    If x = 9 Then Exit Sub



    g = Mid(d, 7, 4)
    If g <= 1899 Or g >= 2101 Then ' ora controlla se l'anno è compreso tra il 1900 ed il 2100 (variabile)
    MsgBox "L'anno deve essere tra il 1900 ed il 2100"
        txtDataArrivo.SelStart = 6
        txtDataArrivo.SelLength = Len(txtDataArrivo)
    Exit Sub
    End If

    If IsDate(txtDataArrivo) = False Then 'ora controlla se la data è una data valida
    MsgBox "La data non è valida - Controllare mese, giorno e anno"
        txtDataArrivo.SelStart = 0
        txtDataArrivo.SelLength = Len(txtDataArrivo)
    Exit Sub
    End If

    If x = 10 Then
        txtNumeroOrdine.SetFocus  'il cursore si sposta su una seconda textbox al fine di far partire "Private Sub textbox1_Exit"
    End If
    Exit Sub

mess:
    MsgBox "Giorno inesistente nel mese " & f & ""
        txtDataArrivo.SelStart = 0
        txtDataArrivo.SelLength = Len(txtDataArrivo)
    Set x = Nothing
    Set Y = Nothing
    Set d = Nothing
    Set e = Nothing
    Set f = Nothing
    Set g = Nothing

    Resume

End Sub
Private Sub txtDataArrivo_Enter()

    txtDataArrivo.BackColor = &HC0FFC0          'colora lo sfondo della textbox attiva

End Sub

Private Sub txtDataInizioIndisponilbiltà_Change()

End Sub





Private Sub txtDataInizioIndisponibilità_Change()
 On Error Resume Next
        x = Len(txtDataInizioIndisponibilità)
        Y = LTrim(txtDataInizioIndisponibilità.Text)
        d = txtDataInizioIndisponibilità
        If d = "" Then
        txtDataInizioIndisponibilità.BackColor = &HFFFFFF
    Exit Sub
End If
    If Left(d, 2) > 31 Then
    MsgBox "Giorno Errato"
        txtDataInizioIndisponibilità.SelStart = 0
        txtDataInizioIndisponibilità.SelLength = Len(txtDataInizioIndisponibilità)
    Exit Sub
End If
    If x = 2 Then txtDataInizioIndisponibilità = Y & "/"
    If x = 4 Then Exit Sub

    If Mid(d, 4, 2) = "" Then Exit Sub
    If Mid(d, 4, 2) > 12 Then 'ora controlliamo che il mese non superi il numero 12, si avvisa, si esce
    MsgBox "Mese Errato"
        txtDataInizioIndisponibilità.SelStart = 3
        txtDataInizioIndisponibilità.SelLength = Len(txtDataInizioIndisponibilità)
    Exit Sub
End If

'--------per rendere completo il sistema di verifica, inseriamo le istruzioni che controllino anche di non superare il 'giorno di fine mese rispetto ai mesi di febbraio e dei mesi a fine 30

    e = Left(d, 2) 'con la variabile "e" prendiamo il giorno della data introdotta
    f = Mid(d, 4, 2) 'con la variabile "f" prendiamo il mese della data introdotta
    Select Case f 'usiamo il Select Case che verificherà il Caso Febbraio (02 in numero)
        Case "02"
            If e > 29 Then GoTo mess 'se il giorno ("e") è maggiore di 29 avvisiamo, selezioniamo e usciamo dalla routine

        Case "04", "06", "09", "11" 'ora si controlla i Case dei mesi di 30 giorni
        If e > 30 Then GoTo mess 'se il giorno ("e") è maggiore di 30 avvisiamo, selezioniamo e usciamo dalla routine
    End Select
    If x = 5 Then
        txtDataInizioIndisponibilità = Y & "/"
    Exit Sub
    End If

    If x = 6 Then Exit Sub
    If x = 7 Then Exit Sub
    If x = 8 Then Exit Sub
    If x = 9 Then Exit Sub



    g = Mid(d, 7, 4)
    If g <= 1899 Or g >= 2101 Then ' ora controlla se l'anno è compreso tra il 1900 ed il 2100 (variabile)
    MsgBox "L'anno deve essere tra il 1900 ed il 2100"
        txtDataInizioIndisponibilità.SelStart = 6
        txtDataInizioIndisponibilità.SelLength = Len(txtDataInizioIndisponibilità)
    Exit Sub
    End If

    If IsDate(txtDataInizioIndisponibilità) = False Then 'ora controlla se la data è una data valida
    MsgBox "La data non è valida - Controllare mese, giorno e anno"
        txtDataInizioIndisponibilità.SelStart = 0
        txtDataInizioIndisponibilità.SelLength = Len(txtDataInizioIndisponibilità)
    Exit Sub
    End If

    If x = 10 Then
        txtNumeroOrdine.SetFocus  'il cursore si sposta su una seconda textbox al fine di far partire "Private Sub textbox1_Exit"
    End If
    Exit Sub

mess:
    MsgBox "Giorno inesistente nel mese " & f & ""
        txtDataInizioIndisponibilità.SelStart = 0
        txtDataInizioIndisponibilità.SelLength = Len(txtDataInizioIndisponibilità)
    Set x = Nothing
    Set Y = Nothing
    Set d = Nothing
    Set e = Nothing
    Set f = Nothing
    Set g = Nothing

    Resume

End Sub
Private Sub txtDataInizioIndisponibilità_Enter()

    txtDataInizioIndisponibilità.BackColor = &HC0FFC0          'colora lo sfondo della textbox attiva

End Sub

'===========================
'===== Eventi UserForm =====
'===========================

Private Sub userform_Initialize()
    
    Set Sh = Worksheets("Database")                         ' Variabile sh = Foglio Database
    With Sh
        lUltRiga = .Range("A" & Rows.Count).End(xlUp).Row   ' Si posiziona sull'ultimo record della tabella
    End With
    
    With Me
        .cmdInserisci.Enabled = False                       ' Pulsante Inserisci Non Visibile
        .Height = 450                                    ' Dimensione iniziale del Form
    End With
   
'****************************************************
' Computer di casa risoluzione 1440 x 900 Orizzontale
' Computer di lavoro risoluzione 1920 x 1080 Orizzontale
' Ridimensiona il Form su tutti i computer.
    'With Me
        '.ScrollBars = fmScrollBarsBoth
        '.ScrollHeight = .InsideHeight * 2
        '.ScrollWidth = .InsideWidth * 2
    'End With
'****************************************************
   
' Attiva la proprietà MultiLine su true in TNote.
    With txtNote
                                                            ' Consente il multilinea nella TNote
                                                            ' Attenzione: questa proprietà è sempre false di default
        .MultiLine = True
        .ScrollBars = fmScrollBarsBoth
        .WordWrap = True
                                                            ' Specifica che premendo il tasto INVIO verrà aggiunta una nuova riga.
        .EnterKeyBehavior = True
    End With
        
End Sub

Private Sub UserForm_Terminate()

    Set Sh = Nothing
    
End Sub


'==================================
'===== Pulsanti frame Ricerca =====
'==================================

Private Sub cmdPrimo_Click()

    With Me
    
        .txtID.Text = Sh.Range("A3").Value
        .txtTecnologia.Text = Sh.Range("B3").Value
        .txtRiferimento1.Text = Sh.Range("C3").Value
        .txtRiferimento2.Text = Sh.Range("D3").Value
        .txtOggetto.Text = Sh.Range("E3").Value
        .txtNote.Text = Sh.Range("F3").Value
        .txtCreaCartella.Text = Sh.Range("G3").Value
        .txtDataCreazioneCartella.Text = Sh.Range("H3").Value
        .txtNomeCartella.Text = Sh.Range("I3").Value
        .txtDataConsegnaOfferta.Text = Sh.Range("J3").Value
        .txtNumeroOrdine.Text = Sh.Range("K3").Value
        .txtDataConsegna.Text = Sh.Range("L3").Value
        .txtCostruttore.Text = Sh.Range("M3").Value
        .txtStatoCommessa.Text = Sh.Range("N3").Value
        .txtDataArrivo.Text = Sh.Range("O").Value
        .txtDataInizioIndisponibilità.Text = Sh.Range("P3").Value.Text = Sh.Range("P").Value
    End With
    
    lRigaAttiva = 3                                         ' Il record Attivo è il 3
    Me.cmdInserisci.Enabled = False                         ' Pulsante Inserisci Non Visibile
    
    
End Sub

Private Sub cmdAvanti_Click()

    If Not lRigaAttiva >= lUltRiga Then
    
        lRigaAttiva = lRigaAttiva + 1                         ' Il record Attivo + 1 (scende di un record)
        
        With Me
        
            .txtID.Text = Sh.Range("A" & lRigaAttiva).Value
            .txtTecnologia.Text = Sh.Range("B" & lRigaAttiva).Value
            .txtRiferimento1.Text = Sh.Range("C" & lRigaAttiva).Value
            .txtRiferimento2.Text = Sh.Range("D" & lRigaAttiva).Value
            .txtOggetto.Text = Sh.Range("E" & lRigaAttiva).Value
            .txtNote.Text = Sh.Range("F" & lRigaAttiva).Value
            .txtCreaCartella.Text = Sh.Range("G" & lRigaAttiva).Value
            .txtDataCreazioneCartella.Text = Sh.Range("H" & lRigaAttiva).Value
            .txtNomeCartella.Text = Sh.Range("I" & lRigaAttiva).Value
            .txtDataConsegnaOfferta.Text = Sh.Range("J" & lRigaAttiva).Value
            .txtNumeroOrdine.Text = Sh.Range("K" & lRigaAttiva).Value
            .txtDataConsegna.Text = Sh.Range("L" & lRigaAttiva).Value
            .txtCostruttore.Text = Sh.Range("M" & lRigaAttiva).Value
            .txtStatoCommessa.Text = Sh.Range("N" & lRigaAttiva).Value
            .txtDataArrivo.Text = Sh.Range("O" & lRigaAttiva).Value
            .txtDataInizioIndisponibilità.Text = Sh.Range("P" & lRigaAttiva).Value
            
            
            
        End With
        
    End If
    
    Me.cmdInserisci.Enabled = False                         ' Pulsante Inserisci Non Visibile
    
End Sub

Private Sub cmdIndietro_Click()

    If Not lRigaAttiva <= 2 Then
    
        lRigaAttiva = lRigaAttiva - 1                       ' Il record Attivo - 1 (sale di 1 record)
        
        With Me
            
            .txtID.Text = Sh.Range("A" & lRigaAttiva).Value
            .txtTecnologia.Text = Sh.Range("B" & lRigaAttiva).Value
            .txtRiferimento1.Text = Sh.Range("C" & lRigaAttiva).Value
            .txtRiferimento2.Text = Sh.Range("D" & lRigaAttiva).Value
            .txtOggetto.Text = Sh.Range("E" & lRigaAttiva).Value
            .txtNote.Text = Sh.Range("F" & lRigaAttiva).Value
            .txtCreaCartella.Text = Sh.Range("G" & lRigaAttiva).Value
            .txtDataCreazioneCartella.Text = Sh.Range("H" & lRigaAttiva).Value
            .txtNomeCartella.Text = Sh.Range("I" & lRigaAttiva).Value
            .txtDataConsegnaOfferta.Text = Sh.Range("J" & lRigaAttiva).Value
            .txtNumeroOrdine.Text = Sh.Range("K" & lRigaAttiva).Value
            .txtDataConsegna.Text = Sh.Range("L" & lRigaAttiva).Value
            .txtCostruttore.Text = Sh.Range("M" & lRigaAttiva).Value
            .txtStatoCommessa.Text = Sh.Range("N" & lRigaAttiva).Value
            .txtDataArrivo.Text = Sh.Range("O" & lRigaAttiva).Value
             txtDataInizioIndisponibilità.Text = Sh.Range("P" & lRigaAttiva).Value.Text = Sh.Range("O" & lRigaAttiva).Value
        End With
        
    End If
    
    Me.cmdInserisci.Enabled = False                         ' Pulsante Inserisci Non Visibile
    
End Sub

Private Sub cmdUltimo_Click()

    With Me
    
            .txtID.Text = Sh.Range("A" & lUltRiga).Value
            .txtTecnologia.Text = Sh.Range("B" & lUltRiga).Value
            .txtRiferimento1.Text = Sh.Range("C" & lUltRiga).Value
            .txtRiferimento2.Text = Sh.Range("D" & lUltRiga).Value
            .txtOggetto.Text = Sh.Range("E" & lUltRiga).Value
            .txtNote.Text = Sh.Range("F" & lUltRiga).Value
            .txtCreaCartella.Text = Sh.Range("G" & lUltRiga).Value
            .txtDataCreazioneCartella.Text = Sh.Range("H" & lUltRiga).Value
            .txtNomeCartella.Text = Sh.Range("I" & lUltRiga).Value
            .txtDataConsegnaOfferta.Text = Sh.Range("J" & lUltRiga).Value
            .txtNumeroOrdine.Text = Sh.Range("K" & lUltRiga).Value
            .txtDataConsegna.Text = Sh.Range("L" & lUltRiga).Value
            .txtCostruttore.Text = Sh.Range("M" & lUltRiga).Value
            .txtStatoCommessa.Text = Sh.Range("N" & lUltRiga).Value
            .txtDataArrivo.Text = Sh.Range("O" & lUltRiga).Value
            .txtDataInizioIndisponibilità.Text = Sh.Range("P" & lUltRiga).Value
            
            
    End With
    
    lRigaAttiva = lUltRiga                                  ' La riga attiva è l'ultima
    Me.cmdInserisci.Enabled = False                         ' Pulsante Inserisci Non Visibile
    
End Sub

Private Sub cmdTrova_Click()

    With Me
        .Height = 600                                     ' Dimensione del Form quando si preme il pulsante Trova
    End With
    
End Sub


'=================================
'===== Pulsanti frame Esegui =====
'=================================

Private Sub cmdNuovo_Click()

    Dim sFunzione As String
    
    sFunzione = "MAX(A2:A" & lUltRiga & ")+1"
    
    Call mPulisciTextBox
    lNuovoID = Evaluate(sFunzione)
    
    With Me
        .txtID.Value = lNuovoID
        .cmdInserisci.Enabled = True
        .txtTecnologia.SetFocus
    End With
    
End Sub

Private Sub cmdInserisci_Click()
    With Me
        If Len(.txtTecnologia.Text) = 0 Then
            MsgBox _
                "Attenzione il campo 'Tecnologia' è OBBLIGATORIO", , "Campo obbligatorio"
            Exit Sub
        End If
    End With
    
    With Sh
    
        .Unprotect password:=""
        lUltRiga = lUltRiga + 1
        .Range("A" & lUltRiga).Value = Me.txtID.Text
        .Range("B" & lUltRiga).Value = Me.txtTecnologia.Text
        .Range("C" & lUltRiga).Value = Me.txtRiferimento1.Text
        .Range("D" & lUltRiga).Value = Me.txtRiferimento2.Text
        .Range("E" & lUltRiga).Value = Me.txtOggetto.Text
        .Range("F" & lUltRiga).Value = Me.txtNote.Text
        .Range("G" & lUltRiga).Value = Me.txtCreaCartella.Text
        .Range("H" & lUltRiga).Value = Me.txtDataCreazioneCartella.Text
        .Range("I" & lUltRiga).Value = Me.txtNomeCartella.Text
        .Range("J" & lUltRiga).Value = Me.txtDataConsegnaOfferta.Text
        .Range("K" & lUltRiga).Value = Me.txtNumeroOrdine.Text
        .Range("L" & lUltRiga).Value = Me.txtDataConsegna.Text
        .Range("M" & lUltRiga).Value = Me.txtCostruttore.Text
        .Range("N" & lUltRiga).Value = Me.txtStatoCommessa.Text
        .Range("O" & lUltRiga).Value = Me.txtDataArrivo.Text
        .Range("P" & lUltRiga).Value = Me.txtDataInizioIndisponibilità.Text
        .Protect password:=""
        
        MsgBox "Dato correttamente salvato, " & Range("A1").Value, vbOKOnly + vbInformation, "Dato salvato"
        
        
        'Call CreaCartellaInWork         ' Crea La cartella in Work
        'Call CreaCartellaInCont         ' Crea La cartella in Cont
        
    End With
    
    Call mPulisciTextBox
    Me.cmdInserisci.Enabled = False
    
End Sub

Private Sub cmdElimina_Click()

    Dim c As Range
    Dim rng As Range
    Dim lRisposta As Long
    
    With Me
        If Len(.txtDitta.Text) = 0 Then
            MsgBox _
                "Nessuna dato da eliminare.", , "Attenzione"
            Set c = Nothing
            Set rng = Nothing
            Exit Sub
        End If
    End With

    lRisposta = MsgBox(Prompt:="Eliminare il record?", Title:="Attenzione", Buttons:=vbYesNo + vbQuestion)
    
    If lRisposta = vbYes Then
    
        Set rng = Sh.Range("A3:A" & lUltRiga)
        
        For Each c In rng
        
            If c.Value = Me.txtID.Text Then
                    Sh.Unprotect password:=""
                    Sh.Rows(c.Row).Delete
                    Sh.Protect password:=""
                    Exit For
            End If
            
        Next
    
        lUltRiga = lUltRiga - 1
        
        Set c = Nothing
        Set rng = Nothing
        
    Else
        Set c = Nothing
        Set rng = Nothing
        Exit Sub
    End If
        
    Call mPulisciTextBox
    Me.cmdInserisci.Enabled = False
    
End Sub

Private Sub cmdModifica_Click()

    Dim lUltRiga As Long
    Dim lRisposta As Long
    Dim rng As Range
    Dim c As Range
    
    lRisposta = MsgBox(Prompt:="Modificare il record?", Title:="Attenzione", Buttons:=vbYesNo + vbQuestion)
    
    If lRisposta = vbYes Then

        With Sh
            
            lUltRiga = .Range("A" & .Rows.Count).End(xlUp).Row
            Set rng = .Range("A3:A" & lUltRiga)
            .Unprotect password:=""
            
            
            For Each c In rng
                If c.Value = Me.txtID.Text Then
                    c.Offset(0, 1).Value = Me.txtTecnologia.Text
                    c.Offset(0, 2).Value = Me.txtRiferimento1.Text
                    c.Offset(0, 3).Value = Me.txtRiferimento2.Text
                    c.Offset(0, 4).Value = Me.txtOggetto.Text
                    c.Offset(0, 5).Value = Me.txtNote.Text
                    c.Offset(0, 6).Value = Me.txtCreaCartella.Text
                    c.Offset(0, 7).Value = Me.txtDataCreazioneCartella.Text
                    c.Offset(0, 8).Value = Me.txtNomeCartella.Text
                    c.Offset(0, 9).Value = Me.txtDataConsegnaOfferta.Text
                    c.Offset(0, 10).Value = Me.txtNumeroOrdine.Text
                    c.Offset(0, 11).Value = Me.txtDataConsegna.Text
                    c.Offset(0, 12).Value = Me.txtCostruttore.Text
                    c.Offset(0, 13).Value = Me.txtStatoCommessa.Text
                    c.Offset(0, 14).Value = Me.txtDataArrivo.Text
                    c.Offset(0, 15).Value = Me.txtDataInizioIndisponibilità.Text
                    Exit For
                End If
            Next
            
            .Protect password:=""
            
        End With
        
    End If
    
    Set c = Nothing
    Set rng = Nothing
    
End Sub

Private Sub cmdChiudi_Click()
Dim Risp As Integer
 Risp = MsgBox("Vuoi uscire veramente? Se Si premi OK, se 'No' premi 'Annulla'", 1 + 64, "")
  If Risp = 1 Then
  Unload Me
Else
 Exit Sub
End If

End Sub


'================================
'===== Pulsanti frame Trova =====
'================================

Private Sub cmdIniziaRicerca_Click()

    Dim ctrl As Control
    Dim lCampo As Long
    Dim lRif As Long
    Dim c As Range
    Dim rng As Range
    Dim lUltRiga As Long
    
    lCampo = 0
    
    With Me
    
        With .frSelezionaCampo
        
            For Each ctrl In .Controls
                If ctrl.Value = True Then
                    lCampo = Mid(ctrl.Name, 4, Len(ctrl.Name))
                End If
            Next
        
        End With
        
        If .txtRicerca <> "" And lCampo <> 0 Then
        
            lUltRiga = Sh.Range("A" & Rows.Count).End(xlUp).Row
            Set rng = Sh.Range("A3:D" & lUltRiga)
            
            For Each c In rng.Range(Cells(1, lCampo), Cells(lUltRiga, lCampo))
                If c.Value = .txtRicerca.Text Then
                    lRif = 4 - lCampo
                    .txtID.Value = Sh.Cells(c.Row, 1).Value
                    .txtTecnologia.Value = Sh.Cells(c.Row, 2).Value
                    .txtRiferimento1.Value = Sh.Cells(c.Row, 3).Value
                    .txtRiferimento2.Value = Sh.Cells(c.Row, 4).Value
                    .txtOggetto.Value = Sh.Cells(c.Row, 5).Value
                    .txtNote.Value = Sh.Cells(c.Row, 6).Value
                    .txtCreaCartella.Value = Sh.Cells(c.Row, 7).Value
                    .txtDataCreazioneCartella.Value = Sh.Cells(c.Row, 8).Value
                    .txtNomeCartella.Value = Sh.Cells(c.Row, 9).Value
                    .txtDataConsegnaOfferta.Value = Sh.Cells(c.Row, 10).Value
                    .txtNumeroOrdine.Value = Sh.Cells(c.Row, 11).Value
                    .txtDataConsegna.Value = Sh.Cells(c.Row, 12).Value
                    .txtCostruttore.Value = Sh.Cells(c.Row, 13).Value
                    .txtStatoCommessa.Value = Sh.Cells(c.Row, 14).Value
                    .txtDataArrivo.Value = Sh.Cells(c.Row, 15).Value
                    .txtDataInizioIndisponibilità.Value = Sh.Cells(c.Row, 16).Value
                    
                    
                    
                    lRigaAttiva = c.Row
                    lRigaValoreTrovato = c.Row
                    Exit For
                End If
            Next
        Else
            MsgBox "Nessun dato inserito o nessun campo di ricerca selezionato.", vbOKOnly, "Attenzione"
        End If
        
    End With
    
    Set ctrl = Nothing
    Set c = Nothing
    Set rng = Nothing
    
End Sub

Private Sub cmdAzzeraRicerca_Click()

    Call mAzzera
    
End Sub

Private Sub cmdTrovaSuccessivo_Click()

    Dim ctrl As Control
    Dim lCampo As Long
    Dim lRif As Long
    Dim c As Range
    Dim rng As Range
    Dim lUltRiga As Long
    
    lCampo = 0
    
    With Me
    
        With .frSelezionaCampo
        
            For Each ctrl In .Controls
                If ctrl.Value = True Then
                    lCampo = Mid(ctrl.Name, 4, Len(ctrl.Name))
                End If
            Next
        
        End With
        
        If .txtRicerca <> "" And lCampo <> 0 Then
        
            lUltRiga = Sh.Range("A" & Rows.Count).End(xlUp).Row
            Set rng = Sh.Range("A" & lRigaValoreTrovato + 1 & ":D" & lUltRiga)

            For Each c In rng.Range(Cells(1, lCampo), Cells(lUltRiga, lCampo))
                If c.Value = .txtRicerca.Text Then
                    lRif = 4 - lCampo
                    .txtID.Value = Sh.Cells(c.Row, 1).Value
                    .txtTecnologia.Value = Sh.Cells(c.Row, 2).Value
                    .txtRiferimento1.Value = Sh.Cells(c.Row, 3).Value
                    .txtRiferimento2.Value = Sh.Cells(c.Row, 4).Value
                    .txtOggetto.Value = Sh.Cells(c.Row, 5).Value
                    .txtNote.Value = Sh.Cells(c.Row, 6).Value
                    .txtCreaCartella.Value = Sh.Cells(c.Row, 7).Value
                    .txtDataCreazioneCartella.Value = Sh.Cells(c.Row, 8).Value
                    .txtNomeCartella.Value = Sh.Cells(c.Row, 9).Value
                    .txtDataConsegnaOfferta.Value = Sh.Cells(c.Row, 10).Value
                    .txtNumeroOrdine.Value = Sh.Cells(c.Row, 11).Value
                    .txtDataConsegna.Value = Sh.Cells(c.Row, 12).Value
                    .txtCostruttore.Value = Sh.Cells(c.Row, 13).Value
                    .txtStatoCommessa.Value = Sh.Cells(c.Row, 14).Value
                    .txtDataArrivo.Value = Sh.Cells(c.Row, 15).Value
                    .txtDataInizioIndisponibilità.Value = Sh.Cells(c.Row, 16).Value
                    
                    
                    
                    lRigaAttiva = c.Row
                    lRigaValoreTrovato = c.Row
                    Exit For
                End If
            Next
        Else
            MsgBox "Nessun dato inserito o nessun campo di ricerca selezionato.", vbOKOnly, "Attenzione"
        End If
        
    End With

    Set ctrl = Nothing
    Set c = Nothing
    Set rng = Nothing
    
End Sub

Private Sub cmdChiudiTrova_Click()

    With Me
        .Height = 500
    End With
    Call mAzzera
    
End Sub


'============================
'===== Routine UserForm =====
'============================

Private Sub mPulisciTextBox()

    Dim ctrl As Control
    
    With Me.frInserimentoCommesse
        For Each ctrl In .Controls
            If TypeOf ctrl Is MSForms.TextBox Then
                    ctrl.Text = ""
            End If
        Next
    End With
    
    Set ctrl = Nothing

End Sub

Public Sub mAzzera()

    Dim ctrl As Control
    
    With Me
    
        With .frSelezionaCampo
    
            For Each ctrl In .Controls
                ctrl.Value = False
            Next
            
        End With
        
        .txtRicerca.Value = ""
        
    End With
    
    lRigaValoreTrovato = 0
    
    Set ctrl = Nothing

End Sub

'===========================
'===== Gestione Data & Ora =====
'===========================

Private Sub UserForm_Activate()

    Recalc                          ' Sub Modulo2 Data & Ora

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
    Disable                          ' Sub Modulo2 Data & Ora

End Sub

'===========================
'====== Formattazione ======
'===========================

Private Sub txtDataCreazioneCartella_Enter()

    txtDataCreazioneCartella.BackColor = &HC0FFFF 'colora lo sfondo della textbox attiva

End Sub

Private Sub txtDataCreazioneCartella_Change()

    On Error Resume Next
        x = Len(txtDataCreazioneCartella)
        Y = LTrim(txtDataCreazioneCartella.Text)
        d = txtDataCreazioneCartella
        If d = "" Then
        txtDataCreazioneCartella.BackColor = &HFFFFFF
    Exit Sub
End If
    If Left(d, 2) > 31 Then
    MsgBox "Giorno Errato"
        txtDataCreazioneCartella.SelStart = 0
        txtDataCreazioneCartella.SelLength = Len(txtDataCreazioneCartella)
    Exit Sub
End If
    If x = 2 Then txtDataCreazioneCartella = Y & "/"
    If x = 4 Then Exit Sub

    If Mid(d, 4, 2) = "" Then Exit Sub
    If Mid(d, 4, 2) > 12 Then 'ora controlliamo che il mese non superi il numero 12, si avvisa, si esce
    MsgBox "Mese Errato"
        txtDataCreazioneCartella.SelStart = 3
        txtDataCreazioneCartella.SelLength = Len(txtDataCreazioneCartella)
    Exit Sub
End If

'--------per rendere completo il sistema di verifica, inseriamo le istruzioni che controllino anche di non superare il 'giorno di fine mese rispetto ai mesi di febbraio e dei mesi a fine 30

    e = Left(d, 2) 'con la variabile "e" prendiamo il giorno della data introdotta
    f = Mid(d, 4, 2) 'con la variabile "f" prendiamo il mese della data introdotta
    Select Case f 'usiamo il Select Case che verificherà il Caso Febbraio (02 in numero)
        Case "02"
            If e > 29 Then GoTo mess 'se il giorno ("e") è maggiore di 29 avvisiamo, selezioniamo e usciamo dalla routine

        Case "04", "06", "09", "11" 'ora si controlla i Case dei mesi di 30 giorni
        If e > 30 Then GoTo mess 'se il giorno ("e") è maggiore di 30 avvisiamo, selezioniamo e usciamo dalla routine
    End Select
    If x = 5 Then
        txtDataCreazioneCartella = Y & "/"
    Exit Sub
    End If

    If x = 6 Then Exit Sub
    If x = 7 Then Exit Sub
    If x = 8 Then Exit Sub
    If x = 9 Then Exit Sub



    g = Mid(d, 7, 4)
    If g <= 1899 Or g >= 2101 Then ' ora controlla se l'anno è compreso tra il 1900 ed il 2100 (variabile)
    MsgBox "L'anno deve essere tra il 1900 ed il 2100"
        txtDataCreazioneCartella.SelStart = 6
        txtDataCreazioneCartella.SelLength = Len(txtDataCreazioneCartella)
    Exit Sub
    End If

    If IsDate(txtDataCreazioneCartella) = False Then 'ora controlla se la data è una data valida
    MsgBox "La data non è valida - Controllare mese, giorno e anno"
        txtDataCreazioneCartella.SelStart = 0
        txtDataCreazioneCartella.SelLength = Len(txtDataCreazioneCartella)
    Exit Sub
    End If

    If x = 10 Then
        txtNumeroOrdine.SetFocus  'il cursore si sposta su una seconda textbox al fine di far partire "Private Sub textbox1_Exit"
    End If
    Exit Sub

mess:
    MsgBox "Giorno inesistente nel mese " & f & ""
        txtDataCreazioneCartella.SelStart = 0
        txtDataCreazioneCartella.SelLength = Len(txtDataCreazioneCartella)
    Set x = Nothing
    Set Y = Nothing
    Set d = Nothing
    Set e = Nothing
    Set f = Nothing
    Set g = Nothing

    Resume

End Sub

Private Sub txtDataConsegnaOfferta_Enter()

    txtDataConsegnaOfferta.BackColor = &HC0FFFF 'colora lo sfondo della textbox attiva

End Sub

Private Sub txtDataConsegnaOfferta_Change()

    On Error Resume Next
        x = Len(txtDataConsegnaOfferta)
        Y = LTrim(txtDataConsegnaOfferta.Text)
        d = txtDataConsegnaOfferta
        If d = "" Then
        txtDataConsegnaOfferta.BackColor = &HFFFFFF
    Exit Sub
End If
    If Left(d, 2) > 31 Then
    MsgBox "Giorno Errato"
        txtDataConsegnaOfferta.SelStart = 0
        txtDataConsegnaOfferta.SelLength = Len(txtDataConsegnaOfferta)
    Exit Sub
End If
    If x = 2 Then txtDataConsegnaOfferta = Y & "/"
    If x = 4 Then Exit Sub

    If Mid(d, 4, 2) = "" Then Exit Sub
    If Mid(d, 4, 2) > 12 Then 'ora controlliamo che il mese non superi il numero 12, si avvisa, si esce
    MsgBox "Mese Errato"
        txtDataConsegnaOfferta.SelStart = 3
        txtDataConsegnaOfferta.SelLength = Len(txtDataConsegnaOfferta)
    Exit Sub
End If

'--------per rendere completo il sistema di verifica, inseriamo le istruzioni che controllino anche di non superare il 'giorno di fine mese rispetto ai mesi di febbraio e dei mesi a fine 30

    e = Left(d, 2) 'con la variabile "e" prendiamo il giorno della data introdotta
    f = Mid(d, 4, 2) 'con la variabile "f" prendiamo il mese della data introdotta
    Select Case f 'usiamo il Select Case che verificherà il Caso Febbraio (02 in numero)
        Case "02"
            If e > 29 Then GoTo mess 'se il giorno ("e") è maggiore di 29 avvisiamo, selezioniamo e usciamo dalla routine

        Case "04", "06", "09", "11" 'ora si controlla i Case dei mesi di 30 giorni
        If e > 30 Then GoTo mess 'se il giorno ("e") è maggiore di 30 avvisiamo, selezioniamo e usciamo dalla routine
    End Select
    If x = 5 Then
        txtDataConsegnaOfferta = Y & "/"
    Exit Sub
    End If

    If x = 6 Then Exit Sub
    If x = 7 Then Exit Sub
    If x = 8 Then Exit Sub
    If x = 9 Then Exit Sub



    g = Mid(d, 7, 4)
    If g <= 1899 Or g >= 2101 Then ' ora controlla se l'anno è compreso tra il 1900 ed il 2100 (variabile)
    MsgBox "L'anno deve essere tra il 1900 ed il 2100"
        txtDataConsegnaOfferta.SelStart = 6
        txtDataConsegnaOfferta.SelLength = Len(txtDataConsegnaOfferta)
    Exit Sub
    End If

    If IsDate(txtDataConsegnaOfferta) = False Then 'ora controlla se la data è una data valida
    MsgBox "La data non è valida - Controllare mese, giorno e anno"
        txtDataConsegnaOfferta.SelStart = 0
        txtDataConsegnaOfferta.SelLength = Len(txtDataConsegnaOfferta)
    Exit Sub
    End If

    If x = 10 Then
        txtNumeroOrdine.SetFocus  'il cursore si sposta su una seconda textbox al fine di far partire "Private Sub textbox1_Exit"
    End If
    Exit Sub

mess:
    MsgBox "Giorno inesistente nel mese " & f & ""
        txtDataConsegnaOfferta.SelStart = 0
        txtDataConsegnaOfferta.SelLength = Len(txtDataConsegnaOfferta)
    Set x = Nothing
    Set Y = Nothing
    Set d = Nothing
    Set e = Nothing
    Set f = Nothing
    Set g = Nothing

    Resume

End Sub

Private Sub txtDataConsegna_Enter()

    txtDataConsegna.BackColor = &HC0FFFF 'colora lo sfondo della textbox attiva

End Sub

Private Sub txtDataConsegna_Change()

    On Error Resume Next
        x = Len(txtDataConsegna)
        Y = LTrim(txtDataConsegna.Text)
        d = txtDataConsegna
        If d = "" Then
        txtDataConsegna.BackColor = &HFFFFFF
    Exit Sub
End If
    If Left(d, 2) > 31 Then
    MsgBox "Giorno Errato"
        txtDataConsegna.SelStart = 0
        txtDataConsegna.SelLength = Len(txtDataConsegna)
    Exit Sub
End If
    If x = 2 Then txtDataConsegna = Y & "/"
    If x = 4 Then Exit Sub

    If Mid(d, 4, 2) = "" Then Exit Sub
    If Mid(d, 4, 2) > 12 Then 'ora controlliamo che il mese non superi il numero 12, si avvisa, si esce
    MsgBox "Mese Errato"
        txtDataConsegna.SelStart = 3
        txtDataConsegna.SelLength = Len(txtDataConsegna)
    Exit Sub
End If

'--------per rendere completo il sistema di verifica, inseriamo le istruzioni che controllino anche di non superare il 'giorno di fine mese rispetto ai mesi di febbraio e dei mesi a fine 30

    e = Left(d, 2) 'con la variabile "e" prendiamo il giorno della data introdotta
    f = Mid(d, 4, 2) 'con la variabile "f" prendiamo il mese della data introdotta
    Select Case f 'usiamo il Select Case che verificherà il Caso Febbraio (02 in numero)
        Case "02"
            If e > 29 Then GoTo mess 'se il giorno ("e") è maggiore di 29 avvisiamo, selezioniamo e usciamo dalla routine

        Case "04", "06", "09", "11" 'ora si controlla i Case dei mesi di 30 giorni
        If e > 30 Then GoTo mess 'se il giorno ("e") è maggiore di 30 avvisiamo, selezioniamo e usciamo dalla routine
    End Select
    If x = 5 Then
        txtDataConsegna = Y & "/"
    Exit Sub
    End If

    If x = 6 Then Exit Sub
    If x = 7 Then Exit Sub
    If x = 8 Then Exit Sub
    If x = 9 Then Exit Sub



    g = Mid(d, 7, 4)
    If g <= 1899 Or g >= 2101 Then ' ora controlla se l'anno è compreso tra il 1900 ed il 2100 (variabile)
    MsgBox "L'anno deve essere tra il 1900 ed il 2100"
        txtDataConsegna.SelStart = 6
        txtDataConsegna.SelLength = Len(txtDataConsegna)
    Exit Sub
    End If

    If IsDate(txtDataConsegna) = False Then 'ora controlla se la data è una data valida
    MsgBox "La data non è valida - Controllare mese, giorno e anno"
        txtDataConsegna.SelStart = 0
        txtDataConsegna.SelLength = Len(txtDataConsegna)
    Exit Sub
    End If

    If x = 10 Then
        txtNumeroOrdine.SetFocus  'il cursore si sposta su una seconda textbox al fine di far partire "Private Sub textbox1_Exit"
    End If
    Exit Sub

mess:
    MsgBox "Giorno inesistente nel mese " & f & ""
        txtDataConsegna.SelStart = 0
        txtDataConsegna.SelLength = Len(txtDataConsegna)
    Set x = Nothing
    Set Y = Nothing
    Set d = Nothing
    Set e = Nothing
    Set f = Nothing
    Set g = Nothing

    Resume

End Sub



Il codice che ho trovato in rete e che ho adattato è:

Private Sub UserForm_Activate()
CuH = frmGestioneDati.Height      'dimensioni iniziali
CuW = frmGestioneDati.Width
'Resize Form
frmGestioneDati.Top = Application.Top
frmGestioneDati.Left = Application.Left
frmGestionedati.Width = Application.Width
frmGestioneDati.Height = Application.Height
'
'Resize contenuto
ZoW = frmGestioneDati.Width / CuW        'calcola zoom
ZoH = frmGestioneDati.Height / CuH
If ZoW < ZoH Then RZoom = ZoW Else RZoom = ZoH
frmGestioneDati.Zoom = RZoom * 100
'
End Sub

di Oscar (utente non iscritto) data: 13/11/2017 22:48:46
Ciao
hai scaricato troppe cose prova il codice sotto

Private Sub UserForm_Initialize()
With Application
        .DisplayAlerts = False
        .WindowState = xlMaximized
    End With
    
    'ridimensiono la UserForm
    With Application
        Me.Top = .Top
        Me.Left = .Left
        Me.Height = .Height
        Me.Width = .Width
    End With
End Sub

Userform a schermo intero
di Luigi (utente non iscritto) data: 13/11/2017 23:04:39
Oscar grazie, non va. Mi continua a dare errori. Se vuoi ti posso inviare il progetto completo.
di alfrimpa data: 13/11/2017 23:10:33
Luigi ti è stato detto in tutte le salse; devi trovare la sub duplicata ed eliminarne una.

Da qui non si scappa.

Non puoi pensare che questo lo faccia qualcun altro.

Alfredo
Userform a schermo intero
di Luigi (utente non iscritto) data: 14/11/2017 00:39:41
Alfredo buonasera: le migliori parole sono quelle non dette. Non ho chiesto aiuto a te, anzi sei quanto mai inopportuno intervenire pure in quest'altro forum visto e considerato la sceneggiata inutile fatta da te e dall'altro (non faccio il nome perchè non presente) solo perchè non avevo messo il codice (è vero lunghissimo) nel tag. Non è il fatto di essere stato richiamato legittimamente da voi per l'errore da me commesso per quanto dopo le mie scuse cmq avete continuato a farmi la guerra oltre che essere oltraggiato dall'altro con la frase "cosa trovi di così difficile nel trovare una Sub dichiarata doppia, con nome uguale ad un'altra? se non riesci nemmeno qui lascia perdere il VBA e passa ad altro". Viceversa GES nonostante abbia cercato di stemperare gli animi voi due avete continuato. I Forum non sono scuole militari, e se un principiante sbaglia (io) e chiede scusa rimane intimorito dalla vostra aggressività per cui cerca l'approdo in altri lidi.
Luigi
di oregon (utente non iscritto) data: 14/11/2017 08:07:13
Luigi, semplicemente la Sub

Private Sub UserForm_Activate()

è presente due volte e questo non è possibile.

La chiamata a Recalc mettila nell'ultima che hai aggiunto ed elimina tutta la prima.
di patel data: 14/11/2017 08:54:57
Non per difendere Alfrimpa, ma non trovare la sub duplicata è segno di cattiva volontà e non è imputabile alla scarsa esperienza. Oltrettutto il debugger ti indica la sub duplicata.
Userform a schermo intero
di Luigi30051962 data: 14/11/2017 10:20:56
Patel buongiorno, talvolta capita che non si riesce a capire cosa bisogna fare specialmente se si è alle prime armi. La mia non era cattiva volontà e la discussione verteva sui modi aggressivi. Cmq se vuoi seguire la discussione in pvt ti scrivo su quale Forum era. Del resto mi ero abbastanza scusato per la lunghezza del codice che non avevo inserito nel tag per cui dopo le mie reiterate scuse credo che non era il caso di continuare a polemizzare. Inoltre ho chiesto help in questo Forum non capisco cosa servisse da parte di Alfredo ripetermi esattamente le stesse cose già dette nell'altro Forum, forse per rimarcare la mia ignoranza e farla presente anche agli altri? Cmq grazie a oregon per l'aiuto che ancora non provo anche se stanotte una soluzione (credo sia diversa dalla sua) l'avevo trovata e che ora allego. Volevo sapere x favore (non lo trovo) la sezione per presentarsi.
Saluti

Luigi
di patel data: 14/11/2017 10:32:22
non credo sia necessario presentarsi su questo forum e che esista una sezione apposita, l'accesso è consentito anche ai non iscritti, comunque la tua risposta a Alfrimpa non è stata un buon biglietto di presentazione, io al posto di oregon non ti avrei risposto
di oregon (utente non iscritto) data: 14/11/2017 11:43:16
Luigi, la mia era solo una indicazione per superare l'errore di cui hai parlato all'inizio e che riguardava la duplicazione di una Sub.

Non era una "soluzione" a nulla di più.

Adesso tu utilizzi altro codice (di cui non mi occupo ...) ma vorrei sapere solo se hai compreso e risolto il problema della "duplicazione" del codice ...
Dall'esempio che hai allegato mi sembra di sì, quindi non vedo cos'altro tu debba provare ...

P.S. E' abbastanza chiaro il forum su cui hai avuto la prima discussione ma, allo stato attuale, non è molto importante.
di oregon (utente non iscritto) data: 14/11/2017 11:45:10
@pael ... io voglio sperare che Luigi sia "andato completamente in palla" e voglio tentare di "resettare" la discussione e dare un'altra chance.

Anche se vedo che non siamo sulla strada giusta ...
Userform a schermo intero
di Luigi30051962 data: 14/11/2017 11:51:43
Oregon grazie per il tuo consiglio, stavo giusto x rispondere visto che pochi minuti fa ho visto che funziona. Si ho capito il tuo suggerimento e ti ringrazio davvero. Se vuoi posso allegare il file per metterlo a disposizione del Forum. Per quanto riguarda l'altro Forum cmq oltre all'incidente di percorso ho cmq trovato sempre disponibilità assoluta (sarei un imbecille davvero se non lo ribadissi) e probabilmente ci sono rimasto così male proprio perchè non mi sarei mai aspettato una reazione così forte nonostante le mie reiterate scuse per l'errore commesso. Cmq anche l'altro è un grande Forum.

Luigi

Vuoi Approfondire?