Разбить ячейку в стобце "А" на значения для прогресий. Объединить макросы в один

[denyssanitskyi]

Здравствуйте ! Помогите объединить эти макросы в один и работоспособный.
Краткое описание: Нужно разбить ячейку в стобце "А" на значения для прогресий.

Код: (vb)

Sub DataSeriesA()
    Range("Таблица1[прогон]").Select
    Selection.TextToColumns Destination:=Range("B2"), DataType:=xlDelimited, _
        TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=True, OtherChar:= _
        "-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
        
Dim iLastRow As Long
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To iLastRow
Cells(i, "AB") = Cells(i, "B")
Cells(i, "AB").DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=Cells(i, "C"), Trend:=False
Next
End Sub
Sub PerviiPustoiStolbec()
'Шаг 1: Объявляем переменные
Dim LastColumn As Long
'Шаг 2: захват последнего использованного номера столбца
LastColumn = Cells(5, Columns.Count).End(xlToLeft).Column
'шаг 3: выбираем следующий пустой столбец
Cells(5, LastColumn).Offset(0, 1).Select
End Sub
Sub PervayaPustayaStroka() 'Шаг 1: Объявляем переменные
Dim LastRow As Long
'Шаг 2: Захват последнего использованного номера строки
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
'Шаг 3: Выбираем следующую строку вниз
Cells(LastRow, 1).Offset(1, 0).Select
End Sub

[vikttur]

Вы бы нормально задачу описали, без ссылок на макросы.

[denyssanitskyi]

Нужно из ячеек столбца "А" последовательно "размножить" значения, например: ячейка "А1" (1-3,10-13) должна создать в строке 1 начиная с "В1" последовательность 1 2 3 "пустая ячейка" 10 11 12 13.

[Дмитрий Щербаков(The_Prist)]

Код: (vb)

Sub AutofillProgressive()
    Dim aSp, x, s$, lr&, res(), lcnt&
    s = Range("A1").Value
    
    If s = "" Then
        Exit Sub
    End If
    
    
    For Each x In Split(s, ",")
        If Len(x) Then
            aSp = Split(x, "-")
            If UBound(aSp) > 0 Then
                If IsNumeric(aSp(0)) And IsNumeric(aSp(1)) Then
                    For lr = aSp(0) To aSp(1)
                        ReDim Preserve res(lcnt)
                        res(lcnt) = lr
                        lcnt = lcnt + 1
                    Next
                End If
            End If
        End If
    Next
    If lcnt > 0 Then
        Range("B1").Resize(lcnt).Value = Application.Transpose(res)
    End If
End Sub

[Дмитрий Щербаков(The_Prist)]

Хотя судя по скрину должно быть вместо этой строки:

Код: (vb)

Range("B1").Resize(lcnt).Value = Application.Transpose(res)

такая:

Код: (vb)

Range("B1").Resize(,lcnt).Value = res

[denyssanitskyi]

Большое спасибо! Подскажите пожалуйста, как сделать для этого кода цикл по строкам

[Дмитрий Щербаков(The_Prist)]

Да, у Вас знания явно не дотягивают даже до азов самостоятельного написания кода Специально взял кусок из приведенного Вами выше кода:

Код: (vb)

Sub AutofillProgressive()
    Dim aSp, x, s$, lr&, res(), lcnt&
    Dim iLastRow&, i&
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 1 To iLastRow
        s = Range("A" & i).Value
        If s <> "" Then
            lcnt = 0
            Erase res
            For Each x In Split(s, ",")
                If Len(x) Then
                    aSp = Split(x, "-")
                    If UBound(aSp) > 0 Then
                        If IsNumeric(aSp(0)) And IsNumeric(aSp(1)) Then
                            For lr = aSp(0) To aSp(1)
                                ReDim Preserve res(lcnt)
                                res(lcnt) = lr
                                lcnt = lcnt + 1
                            Next
                        End If
                    End If
                End If
            Next
            If lcnt > 0 Then
                Range("B" & i).Resize(, lcnt).Value = res
            End If
        End If
    Next
End Sub