Excel - Trasposizione e ripetizione di valori

[EnricoBanco]

Ciao Anthony, ciao a tutti,

domanda: si può fare una macro in vba excel che partendo dai dati disposti come da esempio in "Tabella origine" arrivi a trasporre i dati come in "Tabella Destinazione"?

Cioè una routine che per ogni record trasponda i dati CAP da colonna a righe in una singola colonna ripentendo i valori dei campi corrispondenti (Città, Regione, Paese) relativi ai CAP.

C'è qualcosa del genere nel forum PC-Facile?
A qualcuno è capitato un problema del genere, dove ha trovato indicazioni per risolverlo?

Grazie a tutti!!!



Esempio

Valori da traspondere da colonna a riga: i singoli valori CAP che sono in colonna
Righe da ripetere per ciascun valore CAP: i valori dei campi città, regione e paese corrispondenti ai CAP


Tabella origine:

Città Regione Paese CAP CAP CAP CAP
Roma Lazio Italia 00100 00144 00148 00179
Padova Veneto Italia 40100 40200 40300 40400
Perugia Umbria Italia 20121 20124 20127 20129


Tabella destinazione:

Città Regione Paese Attributo Valore
Roma Lazio Italia CAP 00100
Roma Lazio Italia CAP 00144
Roma Lazio Italia CAP 00148
Roma Lazio Italia CAP 00179
Padova Veneto italia CAP 40100
-----
Perugia Umbria Italia CAP 20121
-----

[EnricoBanco]

Altro dettaglio: le colonne contenenti il valore CAP possono arrivare fino a 11

[EnricoBanco]

Risolto, ho trovato questo codice che funziona benissimo!!!
Cancella e ricompila in Foglio2
Se si aggiungono nuovi record, accoda correttaemente



'Esempio codice

Option Explicit

'--------->>
Public Sub Tester()
Dim WB As Workbook
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range, rCell As Range
Dim arrIn As Variant, arrOut() As Variant
Dim LRow As Long, LCol As Long
Dim i As Long, j As Long, k As Long

Set WB = ThisWorkbook

With WB
Set srcSH = .Sheets("Foglio1")
Set destSH = .Sheets("Foglio2")
End With

With srcSH
LRow = LastRow(srcSH, .Columns("A:A"))
LCol = LastCol(srcSH, .Rows(1))
Set srcRng = .Range("A2").Resize(LRow - 1, LCol)
End With

arrIn = srcRng.Value

For i = 1 To UBound(arrIn, 1)
For j = 4 To UBound(arrIn, 2)
If arrIn(i, j) <> vbNullString Or j = 4 Then
k = k + 1
ReDim Preserve arrOut(1 To 4, 1 To k)
arrOut(1, k) = arrIn(i, 1)
arrOut(2, k) = arrIn(i, 2)
arrOut(3, k) = arrIn(i, 3)
arrOut(4, k) = arrIn(i, j)
End If
Next j
Next i

On Error GoTo XIT
Application.ScreenUpdating = False
With destSH
.Range("A1:D1").Value = Array("Città", "Regione", "Paese", "CAP")
With .Range("A2").Resize(k, 4)
.Columns(1).NumberFormat = "@"
.Value = Application.Transpose(arrOut)
End With
End With

XIT:
Application.ScreenUpdating = True

End Sub

'--------->>
Public Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

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
End Function

'--------->>
Public Function LastCol(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastCol = Rng.Find(What:="*", _
after:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
'<<=========