Ciao a tutti avrei bisogno di un aiuto per creare un codice in VBA in Excel per una ricerca in automatico di numeri

Question

Ciao a tutti,

Ho bisogno di un aiuto per creare un codice VBA in excel che esegua una ricerca 

mi spiego meglio:

ho un folgio di numeri ( inseriti in 3 colonne B, C,D ) con un numero di righe che varia a secondo dei dati inseriti.

Io devo cercare in questo foglio in automatico una combinazione di 2 o 3 numeri ( compresi tra 1 e 30 ) che si ripetono nelle stessa riga ( su un numero massimo di 5000 righe).

una volta individuate le combinazioni devono essere copiate su un altro foglio indicando nella colonna A e B e C i numeri , nella colonna D  il numero totale delle righe in cui sono presenti.

Grazie

Answer 1

Ciao Massimo,

Ho bisogno di un aiuto per creare un codice VBA in excel che esegua una ricerca 

mi spiego meglio:

ho un folgio di numeri ( inseriti in 3 colonne B, C,D ) con un numero di righe che varia a secondo dei dati inseriti.

Io devo cercare in questo foglio in automatico una combinazione di 2 o 3 numeri ( compresi tra 1 e 30 ) che si ripetono nelle stessa riga ( su un numero massimo di 5000 righe).

una volta individuate le combinazioni devono essere copiate su un altro foglio indicando nella colonna A e B e C i numeri , nella colonna D  il numero totale delle righe in cui sono presenti.

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant, arrOut() As Variant, arrNumeri As Variant

    Dim arrRiga As Variant

    Dim Res As Variant, Res2 As Variant

    Dim i As Long, j As Long, k As Long, iCtr As Long

    Dim iRow As Long, jRow As Long

    Dim bMatch As Boolean

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

    Const sFoglio_Destinazione As String = "Foglio2"       '<<=== Modifica

    Res = Application.InputBox( _

          Prompt:="Inserire two o tre numeri separati da un trattino", _

          Type:=2, _

          Title:="NUMERI DA CERCARE")

    arrNumeri = Split(Res, "-")

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglio_Sorgente)

        Set destSH = .Sheets(sFoglio_Destinazione)

    End With

    With srcSH

        iRow = LastRow(srcSH, .Columns("A:A"))

        Set srcRng = .Range("B2:D" & iRow)

          arrIn = srcRng.Value

    End With

    With destSH

        jRow = LastRow(destSH, .Columns("A:A"))

        Set destRng = .Range("A" & jRow + 2)

    End With

    For i = 1 To UBound(arrIn)

        arrRiga = Application.Index(arrIn, i, 0)

        For j = 0 To UBound(arrNumeri)

            Res2 = Application.Match(CLng(arrNumeri(j)), arrRiga, 0)

            bMatch = Not IsError(Res2)

            If Not bMatch Then Exit For

        Next j

        If bMatch Then

            iCtr = iCtr + 1

            ReDim Preserve arrOut(1 To 4, 1 To iCtr)

            For k = 1 To UBound(arrNumeri) + 1

                arrOut(k, iCtr) = arrIn(i, k)

            Next k

            arrOut(4, iCtr) = "Tabella Riga: " & i

        End If

    Next i

    arrOut = Application.Transpose(arrOut)

    destRng.Resize(iCtr, 4).Value = arrOut

End Sub

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

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

===

Regards,

Norman

Answer 2

Ciao Massimo,

sto eseguendo la prova , ma uno damanda non si riesci a fare in modo che il VBA cerca in automatico i numeri senza inserirli in :

    Res = Application.InputBox( _

          Prompt:="Inserire two o tre numeri separati da un trattino", _

          Type:=2, _

          Title:="NUMERI DA CERCARE")

Certamente, a condizione di informare VBA - o me - quali sono i  2 o 3 numeri ( compresi tra 1 e 30 ) :-)

===

Regards,

Norman

Answer 3

Ciao Massimo,

Ok ora ho capito

Ho la netta impressione che ci sia un equivoco!

Se i 2 o 3 numeri da trovare sono invariabili, posso fissarli nel codice; se invece i numeri di interesse sono immessi in un intervallo, posso modificare il codice per leggerli. 

===

Regards,

Norman

Answer 4

ciao Norman,

Ok ora ho capito

Grazie

Massimo

Answer 5

Ciao Norman,

sto eseguendo la prova , ma uno damanda non si riesci a fare in modo che il VBA cerca in automatico i numeri senza inserirli in :

    Res = Application.InputBox( _

          Prompt:="Inserire two o tre numeri separati da un trattino", _

          Type:=2, _

          Title:="NUMERI DA CERCARE")

Grazie

Massimo