Excel Estrarre dati

[Francesco53]

Buongiorno a tutti, ho la seguente difficoltà:
da una serie di dati che vanno dalla colonna A alla colonna E,
devo estrarre e trascrivere dalla colonna H alla colonna L tutti quei dati che hanno in comune il valore della colonna E.
Allego file esempio.

https://www.mediafire.com/file/sspqtabm ... .xlsb/file

Ringrazio chi può aiutarmi a realizzare una macro per risolvere.
Grazie
Francesco

[Anthony47]

Ad esempio:

Codice: Seleziona tutto

Sub ccopia()
Dim I As Long, myMatch, lastE As Long
Dim Fatto As Boolean, cDopp As Long
'
lastE = Cells(Rows.Count, "E").End(xlUp).Row
For I = 1 To lastE - 1
    Fatto = False: cDopp = 0
    If Application.WorksheetFunction.CountIf(Range("L1").Resize(lastE, 1), Cells(I, 5)) = 0 Then
        Do
'        Debug.Print I, Fatto, cDopp, Cells(I, 5)
            myMatch = Application.Match(Cells(I, 5), Range(Cells(I + 1 + cDopp, 5), Cells(lastE + 1, 5)), False)
            If Not IsError(myMatch) Then
                If Fatto = False Then
                    Cells(I, 1).Resize(1, 5).Copy Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
                    Fatto = True
                End If
                Cells(I + cDopp + myMatch, 1).Resize(1, 5).Copy Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
                cDopp = cDopp + myMatch
            Else
                Exit Do
            End If
        DoEvents
        Loop
    End If
Next I
End Sub

Prova...

[Francesco53]

Ciao Anthony, ti ringrazio per il tuo intervento, ma a me servirebbe senza le funzioni di excel se è possibile.
Francesco

[Anthony47]

Codice: Seleziona tutto

Sub cCopia2()
Dim wArr, cLFor, J As Long
Dim I As Long, Fatto As Boolean
'
wArr = Range(Range("E1"), Cells(Rows.Count, "E").End(xlUp)).Value
For I = 1 To UBound(wArr) - 1
    cLFor = wArr(I, 1): Fatto = False
    If cLFor <> "" Then
        For J = I + 1 To UBound(wArr)
            If wArr(J, 1) = cLFor Then
                If Fatto = False Then
                    Cells(I, 1).Resize(1, 5).Copy Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
                    Fatto = True
                End If
                wArr(J, 1) = ""
                Cells(J, 1).Resize(1, 5).Copy Cells(Rows.Count, "H").End(xlUp).Offset(1, 0)
            End If
        Next J
    End If
Next I
End Sub

Così??

[Francesco53]

Grazie Anthony, come sempre perfetto.
Ti porgo i miei sentiti auguri per un sereno Natale.
Francesco