DUPLICARE UNA CELLA PER IL NUMERO DI CELLE CONTENUTE NELLA STESSA RIGA

CODICE	IMPORTO	DATA	PREZZO

Sub Roxxy()
Dim i As Integer
Dim rng As Range
Dim cel As Range
Dim cel1 As Range
Dim ur As Long
Set rng = Range("A3:a7")
For Each cel In rng
    For i = 1 To Application.WorksheetFunction.Count(Range(Cells(cel.Row, "B"), Cells(cel.Row, "I")))
    ur = Cells(Rows.Count, "F").End(xlUp).Row
        Cells(ur + 1, "f").Value = cel.Value
        For Each cel1 In Range(Cells(cel.Row, "B"), Cells(cel.Row, "I"))
            If cel1.Value <> "" Then
                Cells(ur + 1, "g").Value = cel1.Value
                Cells(ur + 1, "h").Value = Cells(2, cel1.Column).Value
            End If
        Next cel1
        Cells(ur + 1, "I").Value = CDbl(cel.Offset(0, 9).Value)
    Next i
Next cel
End Sub

Sub Tabella()
Dim ur As Long, X As Long, Y As Long, Tot As Long, Rg As Long, T As Long
ur = Range("M" & Rows.Count).End(xlUp).Row
If ur > 1 Then Range("M2:P" & ur).ClearContents
ur = Range("A" & Rows.Count).End(xlUp).Row
Rg = 2
For X = 3 To ur
Tot = Application.WorksheetFunction.CountA(Range(Cells(X, 2), Cells(X, 9)))
    If Tot = 0 Then
        Cells(Rg, 13) = Cells(X, 1)
        Cells(Rg, 16) = Cells(X, 10)
        Rg = Rg + 1
    Else
        For Y = 2 To 9
            If Cells(X, Y) <> "" Then
                Cells(Rg, 13) = Cells(X, 1)
                Cells(Rg, 14) = Cells(X, Y)
                Cells(Rg, 15) = Cells(2, Y)
                Cells(Rg, 16) = Cells(X, 10)
                Rg = Rg + 1
            End If
        Next Y
    End If
Next X
End Sub