RIPORTARE DEI VALORI IN BASE A DEI RANGE

Option Explicit

Sub Report()
Application.ScreenUpdating = False
Dim NRc As Long, x As Long, Rcd As Long
Dim k As Integer, y As Integer, z As Integer

    NRc = Range("K" & Rows.Count).End(xlUp).Row
        If NRc < 3 Then NRc = 3
            Range(Cells(3, 11), Cells(NRc, 13)).ClearContents
    NRc = Range("A" & Rows.Count).End(xlUp).Row
    Rcd = 3
    
        For x = 2 To NRc
            y = Right(Cells(x, 3).Value, 3)
            z = Right(Cells(x, 4).Value, 3)
            For k = y To z
                Cells(Rcd, 11).Value = Cells(x, 1).Value
                    If k > 99 Then Cells(Rcd, 12).Value = Left(Cells(x, 3).Value, 5) & k
                    If k < 100 And k > 9 Then
                        Cells(Rcd, 12).Value = Left(Cells(x, 3).Value, 5) & "0" & k
                    End If
                    If k < 10 Then
                        Cells(Rcd, 12).Value = Left(Cells(x, 3).Value, 5) & "00" & k
                    End If
                    
                Cells(Rcd, 13).Value = Cells(x, 5).Value
                    Rcd = Rcd + 1
            Next k
        Next x
Application.ScreenUpdating = True
End Sub

Option Explicit
Sub Report()
Application.ScreenUpdating = False
Dim NRc As Long, x As Long, Rcd As Long, w As Long, n As Long, t As Long
Dim y As Integer, z As Integer, Msg1 As String, Msg2 As String
    NRc = Range("K" & Rows.Count).End(xlUp).Row
        If NRc > 2 Then Range(Cells(3, 11), Cells(NRc, 13)).ClearContents: Range(Cells(2, 8), Cells(NRc, 8)).ClearContents
    NRc = Range("A" & Rows.Count).End(xlUp).Row
    Rcd = 3
        For x = 2 To NRc
        If Cells(x, 3) = Cells(x, 4) Then
            Cells(Rcd, 11) = Cells(x, 2)
            Cells(Rcd, 12) = Cells(x, 3)
            Cells(Rcd, 13) = Cells(x, 5)
            Rcd = Rcd + 1
        Else
            t = Len(Cells(x, 3))
            n = 0
            For w = 1 To t
                If IsNumeric(Right(Cells(x, 3).Value, w)) Then n = n + 1 Else Exit For
            Next w
            y = 9 & Right(Cells(x, 3).Value, n)
            z = 9 & Right(Cells(x, 4).Value, n)
            Msg1 = Replace(Cells(x, 3), Right(Cells(x, 3).Value, n), "")
            For k = y To z
                Msg2 = Right(k, n)
                Cells(Rcd, 11) = Cells(x, 2)
                Cells(Rcd, 12) = Msg1 & Msg2
                Cells(Rcd, 13) = Cells(x, 5)
                Rcd = Rcd + 1
            Next k
        End If
        Next x
    Range(Cells(3, 12), Cells(Rcd + 10, 12)).Copy
    Cells(2, 8).PasteSpecial
    NRc = Range("H" & Rows.Count).End(xlUp).Row
    Range(Cells(2, 8), Cells(NRc, 8)).RemoveDuplicates Columns:=1, Header:=xlYes
Application.ScreenUpdating = True
MsgBox "fatto"
End Sub