cerca range in un foglio

Hai un problema con Excel?

Nuova discussione

cerca range in un foglio
di gragor (utente non iscritto) data: 06/05/2014 09:05:26
Buongiorno a tutti, nel foglio1 ho un range "B2:D5" e vorrei individuare se esiste un range con gli stessi valori nel foglio2 ed in caso affermativo la posizione.
Mi sembra che il metodo find cerchi soltanto un valore e non un range di valori.

di Textomb data: 06/05/2014 10:21:10
Per affrontare la questione ho immaginato di costruirmi una matrice su cui memorizzare le stringhe generate dai valori memorizzati negli intervalli del foglio 2 che abbiano la forma del range B2:D5 del foglio 1
Quindi scorrere la matrice e trovata una corrispondenza indicarne l'esatto indirizzo...
Insomma ti propongo uno stralcio di codice che potrà essere certamente migliorato.

Option Explicit

Sub cercaRange_Textomb()

Dim String_A As String, RangeF As Range, cell As Range, i As Long
Dim String_B As String, c As Range, Mr()

'memorizzo il range da cercare del foglio1 in una unica stringa di testo
    For Each cell In Foglio1.Range("b2:d5")
        String_A = String_A & cell
    Next

'Costruisco una matrice di stringhe contenute nel foglio 2

ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

For Each cell In Foglio2.UsedRange
String_B = ""
Set RangeF = cell.Resize(4, 3)
    For Each c In RangeF
        String_B = String_B & c
    Next
        i = i + 1
        Mr(i, 1) = String_B
        Mr(i, 2) = cell.Address
Next

'Infine verifico se esiste una corrispondenza tra la stringa_A del foglio 1 e l'insieme delle Stringhe_B del foglio2

    For i = 1 To UBound(Mr)
        If String_A = Mr(i, 1) Then MsgBox "La prima corrispondenza si trova nell'area " & _
        Foglio2.Range(Mr(i, 2)).Resize(4, 3).Address: Exit Sub
    Next
    MsgBox "Non ci sono corrispondenze "

Set RangeF = Nothing
Erase Mr

End Sub

di gragor (utente non iscritto) data: 06/05/2014 14:11:11
funziona benissimo, grazie, non esistono modi più immediati ?

di scossa data: 06/05/2014 14:17:17
Ciao,

dovresti fornire maggiori informazioni: esempio la ricerca è valida se B2:D5 del foglio1 è presente in F12:H15 o lo sarebbe anche se fossero presenti in E27:J28?

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di gragor (utente non iscritto) data: 06/05/2014 14:29:51
per il momento mi accontento di trovare la prima occorrenza, in seguito proverei ad adattare il codice per trovare le altre, non sono proprio a zero col vba, ma in questo caso non sono riuscito a trovare soluzioni semplici

di Textomb data: 06/05/2014 15:39:24
cit.: per il momento mi accontento di trovare la prima occorrenza, in seguito proverei ad adattare il codice per trovare le altre...
Sinceramente avevo capito che la prima occorrenza ti bastava... Questo è fattibile senza grossi stravolgimenti.

cit. non esistono modi più immediati ?
Sicuramente ci saranno... Al momento però non mi viene nulla in mente. Vedremo se arriveranno altre idee.

Sub cercaRangeS_Textomb()
' Questa routine scansiona l'intero foglio2 e se ci sono più occorrenze riferite al Range B2:D5 del foglio 1 ne restituisce
' gli indirizzi in un unico messaggio di testo.

Dim String_A As String, RangeF As Range, cell As Range, i As Long
Dim String_B As String, c As Range, Mr() As String, Strings As String, MyStr

'memorizzo il range da cercare del foglio1 in una unica stringa di testo
    For Each cell In Foglio1.Range("b2:d5")
        String_A = String_A & cell
    Next

'Costruisco una matrice di stringhe contenute nel foglio 2

ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

    For Each cell In Foglio2.UsedRange
    String_B = ""
    Set RangeF = cell.Resize(4, 3)
        For Each c In RangeF
            String_B = String_B & c
        Next
            i = i + 1
            Mr(i, 1) = String_B
            Mr(i, 2) = cell.Address
    Next

'Individuo tutte le corrispondenze tra la stringa_A del foglio 1 e l'insieme delle Stringhe_B del foglio2
    i = 1
    Do
        If String_A = Mr(i, 1) Then Strings = Strings & Chr(13) & Foglio2.Range(Mr(i, 2)).Resize(4, 3).Address
        i = i + 1
    Loop Until i = UBound(Mr)
    
    If Strings = "" Then
        MsgBox "Non sono state trovate occorrenze"
    Else
        MyStr = Split(Strings, Chr(13))
        MsgBox "Le corrispondenze si trovano in " & Chr(13) & Join(MyStr, vbCr)
    End If
    
Set RangeF = Nothing
Erase Mr

End Sub

di Textomb data: 06/05/2014 16:09:24
Questo mi sembra più fruibile in quanto una volta individuati tutti i Range nel foglio 2 li seleziona.

Sub cercaRangeS_Textomb()
' Questa routine non si ferma alla prima occorrenza ma scansiona l'intero foglio2 e se ci sono più occorrenze restituisce
' gli indirizzi in un unico messaggio di testo.

Dim String_A As String, RangeF As Range, cell As Range, i As Long
Dim String_B As String, c As Range, Mr() As String, Strings As String

'memorizzo il range da cercare del foglio1 in una unica stringa di testo
    For Each cell In Foglio1.Range("b2:d5")
        String_A = String_A & cell
    Next

'Costruisco una matrice di stringhe contenute nel foglio 2

ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

    For Each cell In Foglio2.UsedRange
    String_B = ""
    Set RangeF = cell.Resize(4, 3)
        For Each c In RangeF
            String_B = String_B & c
        Next
            i = i + 1
            Mr(i, 1) = String_B
            Mr(i, 2) = cell.Address
    Next

'Individuo tutte le corrispondenze tra la stringa_A del foglio 1 e l'insieme delle Stringhe_B del foglio2
    i = 1
    Do
        If String_A = Mr(i, 1) Then Strings = Strings & "," & Foglio2.Range(Mr(i, 2)).Resize(4, 3).Address
        i = i + 1
    Loop Until i = UBound(Mr)
    
    If Strings = "" Then
        MsgBox "Non sono state trovate occorrenze"
    Else
        Strings = Right(Strings, Len(Strings) - 1)
        Foglio2.Select
        Range(Strings).Select
        MsgBox "Le corrispondenze si trovano in :" & vbCr & Replace(Strings, ",", vbCr)
    End If
    
Set RangeF = Nothing
Erase Mr

End Sub

di gragor (utente non iscritto) data: 06/05/2014 16:31:22
Grazie Textomb, ma l'ultima soluzione va in crisi se il foglio2 contiene molti dati, se strings supera una certa lunghezza range(strings) va in errore.
di Textomb data: 06/05/2014 16:39:20
Si, è vero Range non accetta stringhe superiori a 260 caratteri.
Se ti interessa selezionare i Range nel foglio 2 (tra l'altro non era tra le richieste) puoi superare l'ostacolo passando le stringhe una alla volta...

di gragor (utente non iscritto) data: 06/05/2014 16:52:38
comunque, ottimo lavoro, per me è più che sufficiente, anche se sono curioso di vedere se sono possibili soluzioni meno complicate. Ho fatto qualche modifica per adattarlo a un range qualsiasi

Sub cercaRange_seleziona()
Dim String_A As String, RangeF As Range, cell As Range, i As Long
Dim String_B As String, c As Range, Mr(), Strings As String
Set rngs = Foglio1.Range("a1:b3")
nrows = rngs.Rows.Count
ncols = rngs.Columns.Count
For Each cell In rngs
    String_A = String_A & cell
Next
ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

For Each cell In Foglio2.UsedRange
  String_B = ""
  Set RangeF = cell.Resize(nrows, ncols)
  For Each c In RangeF
     String_B = String_B & c
  Next
  i = i + 1
  Mr(i, 1) = String_B
  Mr(i, 2) = cell.Address
Next
i = 1
Do
        If String_A = Mr(i, 1) Then Strings = Strings & "," & Foglio2.Range(Mr(i, 2)).Resize(nrows, ncols).Address
        i = i + 1
Loop Until i = UBound(Mr)
If Strings = "" Then
    MsgBox "Non sono state trovate occorrenze"
Else
   ls = Len(Strings)
   Strings = Right(Strings, ls - 1)
   Foglio2.Select
   Range(Strings).Select
   MsgBox "Le corrispondenze si trovano in :" & vbCr & Replace(Strings, ",", vbCr)
End If
Set RangeF = Nothing
Erase Mr
End Sub

di Vecchio Frac data: 06/05/2014 16:53:05
cit. "se strings supera una certa lunghezza range(strings) va in errore."
cit. "è vero Range non accetta stringhe superiori a 260 caratteri."
---> Non ho letto tutta la discussione e forse mi sono perso qualcosa, ma a me non risulta questo limite per un oggetto Range nemmeno nella versione preistorica di Excel 2003.
Se nell'editor di codice, in finestra immediata, digito
range("A1")=string(300,"*")
la cella A1 si riempie di trecento asterischi, con la facile controprova:
?len(range("A1")) 300

Cosa intendevate dire quindi? (non perchè voglia ficcanasare ma perchè sarei contento di esservi utile a risolvere)
di gragor (utente non iscritto) data: 06/05/2014 17:24:45
stiamo parlando di Range(Strings).Select dove Strings ha una lunghezza superiore a 260
di Vecchio Frac data: 06/05/2014 19:02:45
Adesso ho capito, grazie.
Allora forse bisogna usare un'altra strategia e cioè costruire un Range progressivamente mediante Union successivi anzichè tentare di costruire un Range unico passandogli una lunga stringa.
di Textomb data: 06/05/2014 19:06:43
Infatti caro VF (ciao)
questo limite me l'hai insegnato tu.
Io non lo sapevo.
h t t p ://www.excelvba.it/Forum/story/Visual_Basic_for_Applications/un_Range_promiscuo.html

di scossa data: 06/05/2014 20:08:26
cit. V.F.: "Allora forse bisogna usare un'altra strategia e cioè costruire un Range progressivamente mediante Union successivi anzichè tentare di costruire un Range unico passandogli una lunga stringa."

Forse, prima di proporre soluzioni "per tentativi", sarebbe il caso che gragor ci desse un ordine di grandezza delle dimensioni del range del Foglio2 da analizzare ..... se parliamo di due o tremila righe per qualche decina di colonne è una cosa, se parliamo di decine di migliaia di righe per centinaia di colonne la cosa è assai più complicata.

scossa's web site

di lepat (utente non iscritto) data: 06/05/2014 20:15:21
come ho già detto Textomb mi ha risolto già il problema, due o tremila righe per qualche decina di colonne vanno benissimo, sono soltanto curioso di vedere qualche soluzione più semplice, mi accontento anche di consigli sulla strategia da seguire, non vorrei abusare del vostro tempo.

di scossa (utente non iscritto) data: 06/05/2014 22:11:11
Ciao patel,

io mi riferivo a gragor, a meno che .......

Una alternativa può essere la seguente.
Premesse:
Impostiamo il calcolo su manuale
Foglio1 il tuo range B2..D5 da cercare
Foglio2->range A1:U3000 dove cercare

Partiamo dall'idea che se noi mettiamo in A1 del Foglio3 la seguente formula matriciale (confermare con ctrl+maiusc+invio):
=SE(Foglio1!$B$2:$D$5 = Foglio2!A1:D4;1;"")
e la copiamo in B1..U1, poi selezioniamo A1..U1 e copiamo la selezione in A2..A3000, infine facciamo ricalcolare Foglio3, ci troveremo sul Foglio3 nel range A..U1 valorizzate con 1 le sole celle che corrispondo alle celle del Foglio2 in cui è stato trovato il range B2..D5 del Foglio1.
Quindi basta utiizzare selezionare le celle del Foglio3 che contengono 1 per avere gli indirizzi delle corrispondenze.

Il codice sotto esegue il tutto in automatico.

N.B.: per funzionare le ricorrenze sul Foglio2 non devono sovrapporsi.

scossa's web site

Sub cercaRange_scossa()
  Dim rngTarget As Range
  Dim rngFound As Range
  Dim RngEval As Range
  Dim nstart As Single
  
  On Error GoTo scossa_handler
  Application.Calculation = xlCalculationManual
  nstart = Timer
  Set rngTarget = Foglio1.Range("B2:D5")
  Set RngEval = Foglio3.Range("A1")
  RngEval.FormulaArray = "=IF(Foglio1!$B$2:$D$5 = Foglio2!A1:D4,1,"""")"
  RngEval.Copy RngEval.Offset(0, 1).Resize(1, 19)
  RngEval.Resize(1, 20).Copy RngEval.Offset(1, 0).Resize(3000, 1)
  Foglio3.Calculate
  Set rngFound = Foglio3.Cells.SpecialCells(xlCellTypeFormulas, xlNumbers)
  If rngFound Is Nothing Then
    Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  Else
    Err.Raise vbObjectError + 513, Description:="corrispondenze trovate in:" & vbCrLf & rngFound.Address(0, 0)
  End If
scossa_handler:
  Foglio3.UsedRange.ClearContents 'eventualmente commentare
  Application.Calculation = xlCalculationAutomatic
  If Err.Number <> 0 Then
    MsgBox Err.Description & vbCrLf & "tempo impiegato: " & Timer - nstart & " secondi"
  End If
  Set rngTarget = Nothing
  Set RngEval = Nothing
  Set rngFound = Nothing
End Sub

errata corrige
di scossa (utente non iscritto) data: 06/05/2014 22:14:02
errata: " ci troveremo sul Foglio3 nel range A..U1"
corrige: " ci troveremo sul Foglio3 nel range A1..U3000"

scossa's web site

di gragor (utente non iscritto) data: 07/05/2014 08:54:48
Ho provato la macro di scossa su un foglio di 700 righe e 19 colonne, ma si blocca e non ho capito perché, lanciandola con F8 invece funziona bene. Ho provato ad eliminare i controlli di errore e qualche volta arriva a buon fine (non sempre) però con un tempo 6 volte superiore a quella di Textomb.
Ritornando su quella di Textomb, ho cercato di capirne il funzionamento e la trovo veramente geniale.

di Textomb data: 07/05/2014 09:29:32
@scossa
ho provato la tua routine ma ha considerato tra le occorrenze riscontrate anche range che invece non avrebbe dovuto... Inoltre ha il limite degli intervalli accavallati. In ultimo non seleziona gli intervalli ottenuti. Cosa a mio avviso fondamentale anche se non richiesta. Però l'idea mi piace.

@gragor
ho rivisitato la mia routine in considerazione dell'errore su range(strings).select con oltre 255 caratteri.
A questo punto ho ritenuto inutile, data la considerevole quantità di occorrenze, esprimere un Msgbox con il risultato. Troppo dispersivo. E poi anche Msgbox ha un limite massimo (1000 caratteri circa)

Sub cercaRangeS_Textomb()
' Questa routine non si ferma alla prima occorrenza ma scansiona l'intero foglio2 e se ci sono più occorrenze restituisce
' gli indirizzi in un unico messaggio di testo.

Dim String_A As String, RangeF As Range, cell As Range, i As Long, Nr As Long
Dim String_B As String, c As Range, Mr() As String, StrRange As Range

'memorizzo il range da cercare del foglio1 in una unica stringa di testo
    For Each cell In Foglio1.Range("b2:d5")
        String_A = String_A & cell
    Next

'Costruisco una matrice di stringhe contenute nel foglio 2

ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

    For Each cell In Foglio2.UsedRange
    String_B = ""
    Set RangeF = cell.Resize(4, 3)
        For Each c In RangeF
            String_B = String_B & c
        Next
            i = i + 1
            Mr(i, 1) = String_B
            Mr(i, 2) = cell.Address
    Next

'Individuo tutte le corrispondenze tra la stringa_A del foglio 1 e l'insieme delle Stringhe_B del foglio2
    i = 1
    Do
    
            If String_A = Mr(i, 1) Then
                    If StrRange Is Nothing Then
                        Set StrRange = Range(Mr(i, 2)).Resize(4, 3)
                        Nr = 1
                    Else
                        Set StrRange = Union(StrRange, Range(Mr(i, 2)).Resize(4, 3))
                        Nr = Nr + 1
                    End If
            End If
    i = i + 1
        
    Loop Until i = UBound(Mr)
    
    If StrRange Is Nothing Then
        MsgBox "Non sono state trovate occorrenze"
    Else
        Foglio2.Select
        StrRange.Select
        MsgBox "Sono state trovate Nr. " & Nr & " occorrenze.", vbInformation
    End If

Set RangeF = Nothing
Set StrRange = Nothing
Erase Mr

End Sub

di scossa data: 07/05/2014 11:30:55
cit textomb: "ho provato la tua routine ma ha considerato tra le occorrenze riscontrate anche range che invece non avrebbe dovuto... "

Mi fido e senza verificare buttato tutto al cesso e tiro l'acqua

Ho quindi cambiato completamente approccio, il risultato è il codice sottostante.

Sul mio file, limitando l'usedrange del Foglio2 a A1:AB4536 altrimenti il tuo codice va in "memoria esaurita" (non ho verificato quale sia il limite di celle, essendo legato alla memoria del pc), questi sono i tempi di esecuzione:

Sub cercaRangeS_Textomb()...: 8,45 secondi
Sub cercaRange_scossa().....: 0,0625 secondi

Portando l'usedrange al massimo (A1:XFD1048576) il tempo di esecuzione della mia resta di 0,0625 secondi

Allego il file di prova (CercaRange3.xlsm)

scossa's web site

'---------------------------------------------------------------------------------------
' Procedure : cercaRange_scossa
' Author    : scossa
' Date      : 07/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Sub cercaRange_scossa()
  Dim rngTarget As Range
  Dim rCellaFound As Range
  Dim rngFound As Range
  Dim RngEval As Range
  Dim rngUnion As Range
  Dim nStart As Single
  Dim nStop As Single
  Dim vWhat As Variant
  Dim cAddress As String
  Dim nCols As Long
  Dim nRows As Long
  Dim nOffR As Long
  Dim nOffC As Long
  Dim bFound As Boolean
  Dim nErr As Long
  Dim sErr As String
  
  On Error GoTo scossa_handler
  nStart = Timer
  Set rngTarget = Foglio1.Range("B2:D5")
  nRows = rngTarget.Rows.Count
  nCols = rngTarget.Columns.Count
  Set RngEval = Foglio2.UsedRange
  vWhat = rngTarget.Cells(1, 1).Value
  With RngEval
    Set rCellaFound = .Find(vWhat, _
                     after:=.Cells(.Rows.Count, .Columns.Count), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     searchorder:=xlRows, _
                     SearchDirection:=xlNext, _
                     MatchCase:=False)
  End With
  If rCellaFound Is Nothing Then Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  Set rngUnion = rCellaFound
  cAddress = rCellaFound.Address
  Do
    Application.StatusBar = rCellaFound.Address(0, 0)
    bFound = True
    If rCellaFound.Row <= (Rows.Count - nRows) And rCellaFound.Column <= (Columns.Count - nCols) Then
      Set rngFound = rCellaFound.Resize(nRows, nCols)
      For nOffR = 1 To nRows
        For nOffC = 1 To nCols
          If rngFound.Cells(nOffR, nOffC) <> rngTarget.Cells(nOffR, nOffC) Then
            bFound = False
            Exit For
          End If
        Next
        If bFound = False Then Exit For
      Next
      If bFound Then
        Set rngUnion = Union(rngUnion, rngFound)
        bFound = False
      End If
    End If
    Set rCellaFound = RngEval.FindNext(rCellaFound)
  Loop While Not rCellaFound Is Nothing And rCellaFound.Address <> cAddress
  
  If rngFound.Cells.Count < rngTarget.Cells.Count Then
    Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  Else
    Err.Raise vbObjectError + 514, Description:=rngUnion.Areas.Count & " corrispondenze trovate" & vbCrLf _
      & "(" & Replace(rngUnion.Address(0, 0), ",", "; ") & ")"
  End If
scossa_handler:
  nStop = Timer - nStart
  Application.StatusBar = False
  nErr = Err.Number - vbObjectError
  sErr = Err.Description
  Foglio1.Range("H1").Value = nStop
  If Err.Number <> 0 Then
   If nErr = 514 Then
    rngUnion.Parent.Activate
    rngUnion.Select
    End If
    MsgBox sErr & vbCrLf & vbCrLf & "tempo impiegato: " & nStop & " secondi"
  End If
  
  Set rngTarget = Nothing
  Set RngEval = Nothing
  Set rngFound = Nothing
  Set rCellaFound = Nothing
  Set rngUnion = Nothing
End Sub

di scossa data: 07/05/2014 11:43:14
Piccola correzione.

scossa's web site

'---------------------------------------------------------------------------------------
' Procedure : cercaRange_scossa
' Author    : scossa
' Date      : 07/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Sub cercaRange_scossa()
  Dim rngTarget As Range
  Dim rCellaFound As Range
  Dim rngFound As Range
  Dim RngEval As Range
  Dim rngUnion As Range
  Dim nStart As Single
  Dim nStop As Single
  Dim vWhat As Variant
  Dim cAddress As String
  Dim nCols As Long
  Dim nRows As Long
  Dim nOffR As Long
  Dim nOffC As Long
  Dim bFound As Boolean
  Dim nErr As Long
  Dim sErr As String
  
  On Error GoTo scossa_handler
  nStart = Timer
  Set rngTarget = Foglio1.Range("B2:D5")
  nRows = rngTarget.Rows.Count
  nCols = rngTarget.Columns.Count
  Set RngEval = Foglio2.UsedRange
  vWhat = rngTarget.Cells(1, 1).Value
  With RngEval
    Set rCellaFound = .Find(vWhat, _
                     after:=.Cells(.Rows.Count, .Columns.Count), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     searchorder:=xlRows, _
                     SearchDirection:=xlNext, _
                     MatchCase:=False)
  End With
  If rCellaFound Is Nothing Then Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  'Set rngUnion = rCellaFound
  cAddress = rCellaFound.Address
  Do
    Application.StatusBar = rCellaFound.Address(0, 0)
    bFound = True
    If rCellaFound.Row <= (Rows.Count - nRows) And rCellaFound.Column <= (Columns.Count - nCols) Then
      Set rngFound = rCellaFound.Resize(nRows, nCols)
      For nOffR = 1 To nRows
        For nOffC = 1 To nCols
          If rngFound.Cells(nOffR, nOffC) <> rngTarget.Cells(nOffR, nOffC) Then
            bFound = False
            Exit For
          End If
        Next
        If bFound = False Then Exit For
      Next
      If bFound Then
        If rngUnion Is Nothing Then
          Set rngUnion = rngFound
        Else
          Set rngUnion = Union(rngUnion, rngFound)
        End If
        bFound = False
      End If
    End If
    Set rCellaFound = RngEval.FindNext(rCellaFound)
  Loop While Not rCellaFound Is Nothing And rCellaFound.Address <> cAddress
  
  If rngUnion.Cells.Count < rngTarget.Cells.Count Then
    Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  Else
    Err.Raise vbObjectError + 514, Description:=rngUnion.Areas.Count & " corrispondenze trovate" & vbCrLf _
      & "(" & Replace(rngUnion.Address(0, 0), ",", "; ") & ")"
  End If
scossa_handler:
  nStop = Timer - nStart
  Application.StatusBar = False
  nErr = Err.Number - vbObjectError
  sErr = Err.Description
  Foglio1.Range("H1").Value = nStop
  If Err.Number <> 0 Then
   If nErr = 514 Then
    rngUnion.Parent.Activate
    rngUnion.Select
    End If
    MsgBox sErr & vbCrLf & vbCrLf & "tempo impiegato: " & nStop & " secondi"
  End If
  
  Set rngTarget = Nothing
  Set RngEval = Nothing
  Set rngFound = Nothing
  Set rCellaFound = Nothing
  Set rngUnion = Nothing
End Sub

di scossa data: 07/05/2014 12:03:00
Altra correzione (ho messo la ricerca dei valori esatti e gestito il caso di rngUnion nothing)

scossa's web site

'---------------------------------------------------------------------------------------
' Procedure : cercaRange_scossa
' Author    : scossa
' Date      : 07/05/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Sub cercaRange_scossa()
  Dim rngTarget As Range
  Dim rCellaFound As Range
  Dim rngFound As Range
  Dim RngEval As Range
  Dim rngUnion As Range
  Dim nStart As Single
  Dim nStop As Single
  Dim vWhat As Variant
  Dim cAddress As String
  Dim nCols As Long
  Dim nRows As Long
  Dim nOffR As Long
  Dim nOffC As Long
  Dim bFound As Boolean
  Dim nErr As Long
  Dim sErr As String
  
  On Error GoTo scossa_handler
  nStart = Timer
  Set rngTarget = Foglio1.Range("B2:D5")
  nRows = rngTarget.Rows.Count
  nCols = rngTarget.Columns.Count
  Set RngEval = Foglio2.UsedRange
  vWhat = rngTarget.Cells(1, 1).Value
  With RngEval
    Set rCellaFound = .Find(vWhat, _
                     after:=.Cells(.Rows.Count, .Columns.Count), _
                     LookAt:=xlWhole, _
                     LookIn:=xlFormulas, _
                     searchorder:=xlRows, _
                     SearchDirection:=xlNext, _
                     MatchCase:=True)
  End With
  If rCellaFound Is Nothing Then Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  cAddress = rCellaFound.Address
  Do
    Application.StatusBar = rCellaFound.Address(0, 0)
    bFound = True
    If rCellaFound.Row <= (Rows.Count - nRows) And rCellaFound.Column <= (Columns.Count - nCols) Then
      Set rngFound = rCellaFound.Resize(nRows, nCols)
      For nOffR = 1 To nRows
        For nOffC = 1 To nCols
          If rngFound.Cells(nOffR, nOffC) <> rngTarget.Cells(nOffR, nOffC) Then
            bFound = False
            Exit For
          End If
        Next
        If bFound = False Then Exit For
      Next
      If bFound Then
        If rngUnion Is Nothing Then
          Set rngUnion = rngFound
        Else
          Set rngUnion = Union(rngUnion, rngFound)
        End If
        bFound = False
      End If
    End If
    Set rCellaFound = RngEval.FindNext(rCellaFound)
  Loop While Not rCellaFound Is Nothing And rCellaFound.Address <> cAddress
  
  If Not rngUnion Is Nothing Then
    Err.Raise vbObjectError + 514, Description:=rngUnion.Areas.Count & " corrispondenze trovate" & vbCrLf _
      & "(" & Replace(rngUnion.Address(0, 0), ",", "; ") & ")"
    Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  Else
    Err.Raise vbObjectError + 513, Description:="corrispondenze non trovate"
  End If
scossa_handler:
  nStop = Timer - nStart
  Application.StatusBar = False
  nErr = Err.Number - vbObjectError
  sErr = Err.Description
  Foglio1.Range("H1").Value = nStop
  If Err.Number <> 0 Then
   If nErr = 514 Then
    rngUnion.Parent.Activate
    rngUnion.Select
    End If
    MsgBox sErr & vbCrLf & vbCrLf & "tempo impiegato: " & nStop & " secondi"
  End If
  
  Set rngTarget = Nothing
  Set RngEval = Nothing
  Set rngFound = Nothing
  Set rCellaFound = Nothing
  Set rngUnion = Nothing
End Sub




Sub cercaRangeS_Textomb()
' Questa routine non si ferma alla prima occorrenza ma scansiona l'intero foglio2 e se ci sono più occorrenze restituisce
' gli indirizzi in un unico messaggio di testo.

Dim String_A As String, RangeF As Range, cell As Range, i As Long, Nr As Long
Dim String_B As String, c As Range, Mr() As String, StrRange As Range
Dim nStart As Single, nStop As Single

nStart = Timer
'memorizzo il range da cercare del foglio1 in una unica stringa di testo
    For Each cell In Foglio1.Range("b2:d5")
        String_A = String_A & cell
    Next

'Costruisco una matrice di stringhe contenute nel foglio 2

ReDim Mr(1 To Foglio2.UsedRange.Count, 1 To 2)

    For Each cell In Foglio2.UsedRange
    String_B = ""
    Set RangeF = cell.Resize(4, 3)
        For Each c In RangeF
            String_B = String_B & c
        Next
            i = i + 1
            Mr(i, 1) = String_B
            Mr(i, 2) = cell.Address
    Next

'Individuo tutte le corrispondenze tra la stringa_A del foglio 1 e l'insieme delle Stringhe_B del foglio2
    i = 1
    Do
    
            If String_A = Mr(i, 1) Then
                    If StrRange Is Nothing Then
                        Set StrRange = Range(Mr(i, 2)).Resize(4, 3)
                        Nr = 1
                    Else
                        Set StrRange = Union(StrRange, Range(Mr(i, 2)).Resize(4, 3))
                        Nr = Nr + 1
                    End If
            End If
    i = i + 1
        
    Loop Until i = UBound(Mr)
    nStop = Timer - nStart
    Foglio1.Range("G1").Value = nStop
    If StrRange Is Nothing Then
        MsgBox "Non sono state trovate occorrenze"
    Else
        Foglio2.Select
        StrRange.Select
        MsgBox "Sono state trovate Nr. " & Nr & " occorrenze." & _
          vbCrLf & vbCrLf & "tempo impiegato: " & nStop & " secondi", vbInformation
    End If

Set RangeF = Nothing
Set StrRange = Nothing
Erase Mr

End Sub

di gragor (utente non iscritto) data: 07/05/2014 12:09:20
@Textomb
ottima modifica, però devi spostare la riga "Foglio2.Select" un po' più in alto altrimenti, se rimane selezionato il foglio1, la riga "StrRange.Select" dà errore

@scossa
non ci sono parole per commentare in modo adeguato, semplice e velocissima

di Textomb data: 07/05/2014 13:29:04
@gragor
hai ragione!!
Il problema sta nell'indirizzo dato al range StrRange... ho omesso per errore il riferimento al Foglio2
Sostituisci la parte del codice con la seguente e funzionerà anche se lanci la routine dal Foglio1.

@Scossa
Ottima idea. Usare Find!!! e poi fargli cercare gli altri riferimenti partendo da lì. Quindi scansiona solo le aree indiziate risparmiando nel tempo di esecuzione.

If StrRange Is Nothing Then
                        Set StrRange = Foglio2.Range(Mr(i, 2)).Resize(4, 3)
                        Nr = 1
                    Else
                        Set StrRange = Union(StrRange, Foglio2.Range(Mr(i, 2)).Resize(4, 3))
                        Nr = Nr + 1
                    End If

di gragor (utente non iscritto) data: 07/05/2014 17:09:24
pienamente RISOLTO, grazie a tutti

Vuoi Approfondire?