Inputbox o Userform dinamica

Question

Ciao a tutti,

Mi affido a voi per ricevere l’aiuto che ho sempre beneficiato ogni volta che vi ho presentato il problema. Avrei la necessità tramite un input box o Userform con 2 textbox (decidete voi secondo la vostra esperienza quale delle 2 è più adatta)  inserire dei numeri e ricevere i nominativi che corrispondono a quei numeri. Entro nello specifico mediante esempio in modo da capire meglio. Se il foglio attivo porta il nome di uno dei 12 mesi dell’anno, eseguendo la macro mi deve uscire la input box o Userform e gli devo dire ad esempio dimmi quanti sono i nominativi riportati nella colonna da B10:B200 che nella colonna E10:E200 hanno un numero compreso da 15 a 20 (i numeri inseriti  non sono mai gli stessi), ed elencarmi tramite msgbox quanti sono e chi sono i nominativi indicati. Ad esempio se nella colonna E ci 7 nominativi che rientrano in quei numeri, tramite msgbox mi verrà indicato ci sono 7 nominativi, e di seguito verranno elencati chi sono.

Spero di essere stato esauriente con la mia richiesta e grazie per quello che farete.

Answer 1

... una correzione e qualche miglioramento:

Public Sub TrovaNomiFraValori()

Const cPrc = "TrovaNomiFraValori"

On Error GoTo ErrH

Const cstrPrompt = "Immetti un numero," & vbNewLine & _

                   "oppure due numeri separati da uno spazio."

Const xlTypeText = 2

Const cstrDat = "B10:B200"

Const cstrNum = "E10:E200"

Dim app         As Excel.Application

Dim wsh         As Excel.Worksheet

Dim strPrompt   As String

Dim vntInput    As Variant

Dim strInput()  As String

Dim lngTmp      As Long

Dim lngBgn      As Long

Dim lngEnd      As Long

Dim e           As Long

Dim avntNum     As Variant

Dim avntDat     As Variant

Dim i           As Long

Dim strResult   As String

Dim lngCount    As Long

      Set app = GetObject(Class:="Excel.Application")

      Set wsh = app.ActiveSheet

      If Not IsDate("2000-" & wsh.Name & "-01") Then

        Err.Raise vbObjectError + 1, _

                  cPrc, _

                  "Il nome del foglio attivo non è il nome di un mese."

      End If

      strPrompt = cstrPrompt

      vntInput = ""

      Do

        vntInput = app.InputBox(Prompt:=strPrompt, _

                                Title:=cPrc, _

                                Default:=vntInput, _

                                Type:=xlTypeText)

        If VarType(vntInput) = vbBoolean Then GoTo ExtP

        strInput = Split(Trim$(vntInput), " ")

        On Error Resume Next

        lngBgn = CLng(strInput(LBound(strInput)))

        lngEnd = CLng(strInput(UBound(strInput)))

        e = Err.Number

        On Error GoTo ErrH

        If e Then

          strPrompt = "ATTENZIONE! Immettere numeri." & _

                      vbNewLine & vbNewLine & cstrPrompt

        Else

          If lngBgn > lngEnd Then

            lngTmp = lngBgn

            lngBgn = lngEnd

            lngEnd = lngTmp

          End If

          Exit Do

        End If

      Loop

      With wsh

        avntNum = .Range(cstrNum).Value

        avntDat = .Range(cstrDat).Value

      End With

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

        If lngBgn <= avntNum(i, 1) And avntNum(i, 1) <= lngEnd Then

          If Not (LenB(avntDat(i, 1)) = 0 And avntNum(i, 1) = 0) Then

            lngCount = lngCount + 1

            strResult = strResult & vbNewLine & _

                        avntNum(i, 1) & vbTab & _

                        "'" & avntDat(i, 1) & "'"

          End If

        End If

      Next

      strPrompt = " con valore"

      If lngBgn = lngEnd Then

        strPrompt = strPrompt & _

                    " uguale a " & CStr(lngBgn)

      Else

        strPrompt = strPrompt & _

                    " compreso fra " & CStr(lngBgn) & _

                    " e " & CStr(lngEnd)

      End If

      Select Case lngCount

      Case 0

        strPrompt = "Nessun nominativo presente" & strPrompt

      Case 1

        strPrompt = "Trovato un nominativo presente" & strPrompt

      Case Else

        strPrompt = "Trovato " & CStr(lngCount) & _

                    " nominativi presenti" & strPrompt

      End Select

      strPrompt = strPrompt & ":" & strResult

      MsgBox strPrompt, vbInformation, cPrc

ExtP: On Error Resume Next

      Set wsh = Nothing

      Set app = Nothing

      On Error GoTo 0

      Exit Sub

ErrH:

      MsgBox Err.Description

      Resume ExtP

End Sub

Answer 2

Mi fa piacere. Grazie geacs del cortese riscontro.

Answer 3

Ciao Maurizio,

E' favoloso, non ho parole per definire il codice postato, ho chiesto 100 e ricevo 200. Non solo mi dice quanti sono quelli che soddisfano i valori immessi, vengono elencati anche con il valore accanto (lo trovo utilissimo e pratico), ma lo hai fatto in modo da cercare nello specifico anche chi ha lo stesso valore. Sei grande Maurizio, grazie ancora.

Answer 4

Ciao geacs,

se ho compreso bene il quesito la macro potrebbe essere del tipo:

Public Sub a()

Const cPrc = "a"

On Error GoTo ErrH

Const cstrPrompt = "Immetti un numero," & vbNewLine & _

                   "oppure due numeri separati da uno spazio."

Const xlTypeText = 2

Const cstrDat = "B10:B200"

Const cstrNum = "E10:E200"

Dim app         As Excel.Application

Dim wsh         As Excel.Worksheet

Dim strPrompt   As String

Dim vntInput    As Variant

Dim strInput()  As String

Dim lngTmp      As Long

Dim lngBgn      As Long

Dim lngEnd      As Long

Dim e           As Long

Dim avntNum     As Variant

Dim avntDat     As Variant

Dim i           As Long

Dim strResult   As String

Dim lngCount    As Long

      Set app = GetObject(Class:="Excel.Application")

      Set wsh = app.ActiveSheet

      If Not IsDate("2000-" & wsh.Name & "-01") Then

        Err.Raise vbObjectError + 1, _

                  cPrc, _

                  "Il nome del foglio attivo non è il nome di un mese."

      End If

      strPrompt = cstrPrompt

      vntInput = ""

      Do

        vntInput = app.InputBox(Prompt:=strPrompt, _

                                Title:=cPrc, _

                                Default:=vntInput, _

                                Type:=xlTypeText)

        If vntInput = False Then GoTo ExtP

        strInput = Split(Trim$(vntInput), " ")

        On Error Resume Next

        lngBgn = strInput(LBound(strInput))

        lngEnd = strInput(UBound(strInput))

        e = Err.Number

        On Error GoTo ErrH

        If e Then

          strPrompt = "ATTENZIONE! Immettere numeri." & _

                      vbNewLine & vbNewLine & cstrPrompt

        Else

          If lngBgn > lngEnd Then

            lngTmp = lngBgn

            lngBgn = lngEnd

            lngEnd = lngTmp

          End If

          Exit Do

        End If

      Loop

      With wsh

        avntNum = .Range(cstrNum).Value

        avntDat = .Range(cstrDat).Value

      End With

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

        If lngBgn <= avntNum(i, 1) And avntNum(i, 1) <= lngEnd Then

          lngCount = lngCount + 1

          strResult = strResult & vbNewLine & avntDat(i, 1)

        End If

      Next

      MsgBox "Trovato " & CStr(lngCount) & " nominativo(i):" & _

             strResult

ExtP: On Error Resume Next

      Set wsh = Nothing

      Set app = Nothing

      On Error GoTo 0

      Exit Sub

ErrH:

      MsgBox Err.Description

      Resume ExtP

End Sub