Ciao Matzap
In assenza di tue indicazioni al riguardo ho provveduto, sulla base strettamente dell'esempio da te fornito a scrivere le macro che mi hai richiesto e che ho inserito nel file che vedi linkato
http://www.filedropper.com/matzapLe macro sono queste:
- Codice: Seleziona tutto
Sub DividiTesto()
Dim numrec As Long
numrec = Cells(Rows.Count, 1).End(xlUp).Row
Range("a1:a" & numrec).Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(2, 1), Array(5, 1), Array(13, 1), Array(25, 9), _
Array(29, 1)), TrailingMinusNumbers:=True
End Sub
Questa effettua la suddivisione del testo in colonna A in colonne escludendo le stringhe che non ti interessano.
- Codice: Seleziona tutto
Sub TrasponiTesto()
Dim ur As Long
Dim lr As Long
Dim rng As Range
Dim cel As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a1:a" & lr)
For Each cel In rng
ur = Application.WorksheetFunction.CountA(Range("G:G"))
If ur = 0 Then
ur = 1
End If
Range("A" & cel.Row & ":" & "D" & cel.Row).Select
Selection.Copy
Range("G" & ur).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Next cel
Range("a1").CurrentRegion.ClearContents
End Sub
Questa effettua la "rotazione dei dati in colonna G
Quest'ultima esegue in sequenza le due macro
- Codice: Seleziona tutto
Sub TrasponiDati()
Application.ScreenUpdating = False
Call DividiTesto
Call TrasponiTesto
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Prova un po' il file (sul foglio1 ho messo un pulsante per lanciare la macro) e fai sapere.