Annidare più cicli for each in una unica routine VBA.

Question

Buonasera a tutti.

Chiedo il vostro aiuto (da solo sto provando da diversi giorni e non riesco a farcela).

Ho creato, aiutandomi con ricerche nel forum (in particolare modo utilizzando il codice di Mauro Gamberini) che mi filtra delle materie con un ciclo for next e mi incolla nel Foglio2 i dati filtrati e visibili, lo riporto.

Sub FILTRA_COPIA()

Dim A As Object

Dim m As Range

Dim wk As Workbook

Dim sh1 As Worksheet

Dim sh5 As Worksheet

Set m = Sheets("Foglio1").Range("L2:L6")

For Each A In m

If A = "" & vbNullString Then

Exit For

Else

'''

 'dichiaro le variabili

     With Application

         'v = .InputBox("Inserire la Materia da Filtrare")

         .ScreenUpdating = False

     End With

     'inserisco il criterio di ricerca e impedisco

     'lo sfarfallio del monitor

     'metto un riferimento al workbook

     'che contiene il codice

     Set wk = ThisWorkbook

     'metto un riferimento ai fogli;

     'Foglio1 dove ho la tabella da cui

     'copiare i dati, Foglio5 dove voglio

     'incollare i dati filtrati

     With wk

         Set sh1 = .Worksheets("Foglio1")

         Set sh5 = .Worksheets("Foglio2")

     End With

     'eseguo il filtro/copia/incolla

     With sh1

         'metto il filtro automatico e gli passo

         'come criterio quanto inserito nella

         'InputBox

         .Range("A2").AutoFilter field:=10, _

             Criteria1:=CStr(A)

         'elimino tutti i dati presenti

         'nel Foglio5

         'sh5.Cells.Clear

         'copio/incollo A3:C(n) da foglio tab1

         ' a foglio Provveditorato

         .Range("B2:j" & .Range("A2" _

             ).CurrentRegion.SpecialCells( _

             xlCellTypeLastCell).Row).SpecialCells( _

             xlCellTypeVisible).Copy

     Call CopiaIncolla

         'tolgo il filtro

         .Range("A2").AutoFilter

End With

End If

Next

     'ripristino l'aggiornamento del monitor

     With Application

         .ScreenUpdating = True

     End With

     'Set a Nothing delle variabili oggetto

     Set sh5 = Nothing

     Set sh1 = Nothing

     Set wk = Nothing

End Sub

Sub CopiaIncolla()

 Worksheets("Foglio2").Select

 Range("A65536").End(xlUp).Offset(1, 0).Select

With ActiveCell

 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

 :=False, Transpose:=False

 End With

 End Sub

Ciò che non riesco ad inserire nella Sub FILTRA_COPIA è la procedura ( che ho realizzato e funziona benissimo singolarmente) che posto e che dovrebbe copiarmi, per ogni materia Filtrata il corrispondente numero di righe indicate in un range definito (di colore giallo come da immagine )allegata).

Public Sub CopiaRigheFiltrate()

     Dim sh As Worksheet

     Dim rng As Range

     Dim c As Range

     Dim i As Long

Dim r As Range

Dim rWC As Range

     Set sh = ThisWorkbook.Worksheets("Foglio1")

     Set r = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(12)

     With sh

         Set rng = .Range("M2:M6")

         For Each c In rng

             If c.Value <> vbNullString Then

For Each rWC In r

    i = i + 1

    If i = c Or i = r.Count Then Exit For

Next rWC

Range(r(1), rWC).Resize(, 12).SpecialCells(12).Copy

Call CopiaIncolla

'MsgBox c

'MsgBox c.Offset(0, 1).Address

                 Else

                 Exit For

             End If

         Next

     End With

     Set c = Nothing

     Set rng = Nothing

     Set sh = Nothing

 End Sub

Ringrazio anticipatamente chi mi aiuta in questo.

Mi sono impegnato con tutte le mie forze e le mie conoscenze in VBA, manca poco a far funzionare il tutto ma non riesco proprio ad integrare le 2 routine.

Ciao Nicola.

Answer 1

Buongiorno a tutti.

Dopo tanto impegno, prove e studio ci sono riuscito da solo, sicuramente sarebbe da migliorare in base all'eseprienza e alla bravura di voi esperti del forum.

Posto il codice completo per chi ne avesse bisogno, è basato sul post iniziale.

Sub Filtra_Copia_Valori()

Dim A As Object

Dim M As Range

Dim wk As Workbook

Dim sh1 As Worksheet

Dim sh5 As Worksheet

Set M = ActiveSheet.Range("L2:L6")

For Each A In M

    If A = "" & vbNullString Then

       Exit Sub

    Else

     With Application

             .ScreenUpdating = False

     End With

     'inserisco il criterio di ricerca e impedisco

     'lo sfarfallio del monitor    

     'metto un riferimento al workbook

     'che contiene il codice

     Set wk = ThisWorkbook

     'metto un riferimento ai fogli;

     'Foglio1 dove ho la tabella da cui

     'copiare i dati, Foglio2 dove voglio

     'incollare i dati filtrati

     With wk

         Set sh1 = .Worksheets("Foglio1")

         Set sh5 = .Worksheets("Foglio2")

     End With

     'eseguo il filtro/copia/incolla

     With sh1

         'metto il filtro automatico e gli passo

         'come criterio le Materie inserite nel Range("L2:L6)

         .Range("A2").AutoFilter Field:=10, _

             Criteria1:=CStr(A)

    'poi richiamo la Sub sottoriportata     

    Call TopNRows    

         'tolgo il filtro

         .Range("A2").AutoFilter

End With

End If

Next

     'ripristino l'aggiornamento del monitor

     With Application

         .ScreenUpdating = True

     End With

     'Set a Nothing delle variabili oggetto

     Set sh5 = Nothing

     Set sh1 = Nothing

     Set wk = Nothing

End Sub

Sub TopNRows()

Dim i As Long

Dim r As Range

Dim rWC As Range

Dim c As Object

Dim X As Range

Set X = Sheets("Foglio1").Range("m1")

Set r = Sheets("Foglio1").Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(12)

For Each c In X

If c = vbNullString Then Exit Sub

'MsgBox c

Range("m1") = c

For i = 0 To c

For Each rWC In r

    i = i + 1

    If i = c Or i = r.Count Then Exit For

Next rWC

Range(r(1), rWC).Resize(, 12).SpecialCells(12).Copy

Call CopiaIncolla

Next

Next

End Sub

Sub CopiaIncolla()

 Worksheets("Foglio2").Select

'ora con xlUp troviamo l'ultima cella occupata della colonna A; poichè abbiamo 'bisogno di incollare nella cella immediatamente sotto che è liberà, usiamo Offset 'per spostarci e selezionare detta cella libera, in unica istruzione:

 Range("A65536").End(xlUp).Offset(1, 0).Select

'e ora incollo i dati.

With ActiveCell

 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

 :=False, Transpose:=False

 End With

Application.CutCopyMode = False

Sheets("Foglio1").Select

'esco

 End Sub

Grazie ai vostri insegnamenti, soprattutto agli amici Norman e Mauro Gamberini ( che saluto con affetto e stima e che hanno contribuito alla mia crescita per quanto riguarda il VBA per Excel).

Ciao Nicola.

Answer 2

Buongiorno a tutti.

Avete la possibilità di aiutarmi e farmi capire cosa devo cambiare o aggiungere per il mio obiettivo, sopra descritto?

Ringrazio e auguro buona giornata a tutti.

Ciao Nicola.