Ho lavorato di fantasia sul file pubblicato, e alla fine ho elaborato questo codice:
- Codice: Seleziona tutto
Dim J As Long
Sub reshit()
Dim VArrA, VArrF, VArrK, LastA As Long, LastF As Long, LastK As Long, DestSh As String
Application.ScreenUpdating = False
DestSh = "Sheet2" '<<< Il foglio dove sara' creato il nuovo listato
J = 1
LastA = Cells(Rows.Count, 1).End(xlUp).Row
LastF = Cells(Rows.Count, 6).End(xlUp).Row
LastK = Cells(Rows.Count, 11).End(xlUp).Row
VArrA = Range("A2").Resize(LastA - 1, 1).Value
VArrF = Range("F2").Resize(LastF - 1, 4).Value
VArrK = Range("K2").Resize(LastK - 1, 4).Value
Sheets(DestSh).Cells.ClearContents
Range("A1").Resize(LastA, 4).Copy Sheets(DestSh).Range("A1")
aaaa = coReshit(VArrF, 6, Sheets(DestSh).Range("A1").Resize(LastA + J, 1))
aaaa = coReshit(VArrK, 11, Sheets(DestSh).Range("A1").Resize(LastA + J, 1))
Application.ScreenUpdating = True
MsgBox ("Completato")
End Sub
Function coReshit(ByRef myArr, ByVal mycol As Long, ByRef myArea As Range)
Dim I As Long, myMatch, ColCod As Long, startI As Range
J = 1
ColCod = LBound(myArr, 2)
Set startI = myArea.Cells(1, 1).Offset(20000, 0).End(xlUp)
For I = LBound(myArr, 1) To UBound(myArr, 1)
myMatch = Application.Match(myArr(I, ColCod), myArea, False)
If Not IsError(myMatch) Then
myArea.Cells(myMatch, mycol) = myArr(I, ColCod)
myArea.Cells(myMatch, mycol + 1) = myArr(I, ColCod + 1)
myArea.Cells(myMatch, mycol + 2) = myArr(I, ColCod + 2)
myArea.Cells(myMatch, mycol + 3) = myArr(I, ColCod + 3)
Else
startI.Offset(J, 0) = myArr(I, ColCod)
startI.Offset(J, mycol - 1).Value = myArr(I, ColCod)
startI.Offset(J, mycol + 0).Value = myArr(I, ColCod + 1)
startI.Offset(J, mycol + 1).Value = myArr(I, ColCod + 2)
startI.Offset(J, mycol + 2).Value = myArr(I, ColCod + 3)
J = J + 1
End If
Next I
End Function
Da excel:
-premi Alt-F11; si apre l' editor delle macro
-Menu /Inserisci /Modulo
-Copi il codice e lo incolli nel frame di dx.
L' istruzione marcata <<< va personalizzata col nome di un foglio in cui sara' ricostruito il nuovo elenco; il foglio deve gia' esistere, e SARA' AZZERATO ALL'INIZIO SENZA PREAVVISO.
Poi torni su Excel, attivi il foglio contenente l' elenco da sistemare e lanci la macro "reshit":
-Premi Alt-F8, scegli reshit dall' elenco di macro disponibili, premi Esegui.
Poi controlla l'esito sul foglio di output.
Ciao