Shift rows to the right based on the value in a cell

[gwilkins]

I want to shift each row to the right based on the value in the cell in column A. Skip the header row.
If row 2 has a 1 in cell A2, then the entire second row shifts to the right one column.
If row 3 has a 2 in cell A3, then the entire third row shifts to the right 2 columns and so on through all rows on the active sheet.
ChatGPT failed me. )

Thanks!

 

[dreid1011]

What triggers the shift? One time execution, or each time a value is changed in column A? Does the shift include column A or start at column B?

 

[gwilkins]

What triggers the shift? One time execution, or each time a value is changed in column A? Does the shift include column A or start at column B?

one time. I'm just cleaning up the spreadsheet the way I want.

 

[dreid1011]

one time. I'm just cleaning up the spreadsheet the way I want.

Okay, and the other question? Does the shift include column A or not?

 

[gwilkins]

Okay, and the other question? Does the shift include column A or not?

It doesn't have to but if that makes it easier, than no. Otherwise include col A.

 

[dreid1011]

Alright, two options then:

Including column A:

Private Sub DataShiftA()
Dim lRow As Long, shiftN As Long, i As Long
Dim rng As Range, c As Range

lRow = Range("A" & Rows.Count).End(xlUp).Row

Set rng = Range("A2:A" & lRow)

Application.ScreenUpdating = False
For Each c In rng
    shiftN = c.Value
    For i = 1 To shiftN
        c.Insert Shift:=xlToRight
    Next i
Next c
Application.ScreenUpdating = True
End Sub

Excluding column A:

Private Sub DataShiftB()
Dim lRow As Long, shiftN As Long, i As Long
Dim rng As Range, c As Range

lRow = Range("A" & Rows.Count).End(xlUp).Row

Set rng = Range("B2:B" & lRow)

Application.ScreenUpdating = False
For Each c In rng
    shiftN = c.Offset(, -1).Value
    For i = 1 To shiftN
        c.Insert Shift:=xlToRight
    Next i
Next c
Application.ScreenUpdating = True
End Sub

 

[gwilkins]

Alright, two options then:

Including column A:

Private Sub DataShiftA()
Dim lRow As Long, shiftN As Long, i As Long
Dim rng As Range, c As Range

lRow = Range("A" & Rows.Count).End(xlUp).Row

Set rng = Range("A2:A" & lRow)

Application.ScreenUpdating = False
For Each c In rng
    shiftN = c.Value
    For i = 1 To shiftN
        c.Insert Shift:=xlToRight
    Next i
Next c
Application.ScreenUpdating = True
End Sub

Excluding column A:

Private Sub DataShiftB()
Dim lRow As Long, shiftN As Long, i As Long
Dim rng As Range, c As Range

lRow = Range("A" & Rows.Count).End(xlUp).Row

Set rng = Range("B2:B" & lRow)

Application.ScreenUpdating = False
For Each c In rng
    shiftN = c.Offset(, -1).Value
    For i = 1 To shiftN
        c.Insert Shift:=xlToRight
    Next i
Next c
Application.ScreenUpdating = True
End Sub

You sir, can now claim that you are smarter than ChatGPT!! Thank you very much!

 

[dreid1011]

You sir, can now claim that you are smarter than ChatGPT!! Thank you very much!

You're welcome, happy to help. And thanks.