[Iska]

storm_Zcooler, не доглядел с первого раза, не понял до конца Вашей потребности. Приношу Вам свои извинения.

Значит, будет достаточно проверять счётчик и на последнем проходе цикла разбора дублировать и ячейки справа, наподобие:

читать дальше »

Код:

Option Explicit

Sub SomeSample()
    Dim objRange As Range
    
    Dim i As Long
    Dim j As Long
    
    Dim arrValues() As String
    
    
    With Selection.Cells
        For i = .Count To 1 Step -1
            With .Item(i)
                arrValues = Split(.Value, ",")
                
                For j = UBound(arrValues) To LBound(arrValues) Step -1
                    .EntireRow.Offset(1).Insert
                    
                    .Offset(1, 0).Value = arrValues(j)
                    
                    .Offset(1, -4).Value = .Offset(0, -4).Value
                    .Offset(1, -3).Value = .Offset(0, -3).Value
                    .Offset(1, -2).Value = .Offset(0, -2).Value
                    .Offset(1, -1).Value = .Offset(0, -1).Value
                    
                    If j = LBound(arrValues) Then
                        .Offset(1, 1).Value = .Offset(0, 1).Value
                        .Offset(1, 2).Value = .Offset(0, 2).Value
                        .Offset(1, 3).Value = .Offset(0, 3).Value
                        .Offset(1, 4).Value = .Offset(0, 4).Value
                    End If
                Next
                
                .EntireRow.Delete
            End With
        Next
    End With
End Sub

Или вовсе на последнем проходе новую строку не добавлять, саму оригинальную строку не удалять, а просто менять значение разбираемой ячейки на последнее значение разбора:

читать дальше »

Код:

Option Explicit

Sub SomeSample()
    Dim objRange As Range
    
    Dim i As Long
    Dim j As Long
    
    Dim arrValues() As String
    
    
    With Selection.Cells
        For i = .Count To 1 Step -1
            With .Item(i)
                arrValues = Split(.Value, ",")
                
                For j = UBound(arrValues) To LBound(arrValues) Step -1
                    If j = LBound(arrValues) Then
                        .Value = arrValues(j)
                    Else
                        .EntireRow.Offset(1).Insert
                        
                        .Offset(1, 0).Value = arrValues(j)
                        
                        .Offset(1, -4).Value = .Offset(0, -4).Value
                        .Offset(1, -3).Value = .Offset(0, -3).Value
                        .Offset(1, -2).Value = .Offset(0, -2).Value
                        .Offset(1, -1).Value = .Offset(0, -1).Value
                    End If
                Next
            End With
        Next
    End With
End Sub

Думаю, так даже лучше будет.