VBA How to FillDown with linear..Based on Cell value

[lolamir]

Hi Boys & Girls,

Please, help me..

I have this:

ColumnA ColumnB
SN qtty
ac227 3
cz122 2
7787 4

And i need this:

ColumnA ColumnB
SN qtty
ac227 3
ac228
ac229
cz122 2
cz123
7787 4
7788
7789
7790

I believe this is enough to understand my needs..

 

[MARK858]

Probably much better ways of achieving this but try...

Sub xmas()
    Dim LstRw As Long, xRow As Long
    
    LstRw = Range("A" & Rows.Count).End(xlUp).Row
   
    Application.ScreenUpdating = False
    
    For xRow = LstRw To 2 Step -1
        Cells(xRow, 1).Offset(1).EntireRow.Resize(Cells(xRow, 1).Offset(, 1).Value - 1).Insert
        Cells(xRow, 1).AutoFill Cells(xRow, 1).Resize(Cells(xRow, 1).Offset(, 1).Value), Type:=xlFillSeries
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[lolamir]

Marry Xmas.
I thank you so much..
Don't be modest..It works..Except if value in B is 1.
Any idea..
If not..don't bother..It's Xmas time.

Probably much better ways of achieving this but try...

Sub xmas()
    Dim LstRw As Long, xRow As Long
    
    LstRw = Range("A" & Rows.Count).End(xlUp).Row
   
    Application.ScreenUpdating = False
    
    For xRow = LstRw To 2 Step -1
        Cells(xRow, 1).Offset(1).EntireRow.Resize(Cells(xRow, 1).Offset(, 1).Value - 1).Insert
        Cells(xRow, 1).AutoFill Cells(xRow, 1).Resize(Cells(xRow, 1).Offset(, 1).Value), Type:=xlFillSeries
    Next
    
    Application.ScreenUpdating = True
End Sub

 

[MARK858]

Don't be modest..It works..Except if value in B is 1.
Any idea..

Nothing to do with modesty, just should be a better way code below will deal with the 1 situation

Sub xmas2()
    Dim LstRw As Long, xRow As Long

    LstRw = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False

    For xRow = LstRw To 2 Step -1
        If Cells(xRow, 1).Offset(, 1).Value <> 1 Then
            Cells(xRow, 1).Offset(1).EntireRow.Resize(Cells(xRow, 1).Offset(, 1).Value - 1).Insert
            Cells(xRow, 1).AutoFill Cells(xRow, 1).Resize(Cells(xRow, 1).Offset(, 1).Value), Type:=xlFillSeries
        End If
    Next

    Application.ScreenUpdating = True
End Sub

 

[lolamir]

It works Fantastic..Thank you..
Trying to figure out how to make it work with columns B and C or A and C..
But I can't..
Is is too much I'm asking now..

Nothing to do with modesty, just should be a better way code below will deal with the 1 situation

Sub xmas2()
    Dim LstRw As Long, xRow As Long

    LstRw = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False

    For xRow = LstRw To 2 Step -1
        If Cells(xRow, 1).Offset(, 1).Value <> 1 Then
            Cells(xRow, 1).Offset(1).EntireRow.Resize(Cells(xRow, 1).Offset(, 1).Value - 1).Insert
            Cells(xRow, 1).AutoFill Cells(xRow, 1).Resize(Cells(xRow, 1).Offset(, 1).Value), Type:=xlFillSeries
        End If
    Next

    Application.ScreenUpdating = True
End Sub

 

[MARK858]

In the code below the red 1's are the column references (which I could/should have written as

Cells(xRow,[COLOR="#FF0000"][B]"A"[/B][/COLOR])

which you probably would have understood better) so you make the 1 either 2 or "B" for the "SN" column if you wanted it to be column B.

The blue 1 is how many columns to the right the "Qtty" column is compared to the "SN" column.
So for instance if your "SN" column was A and you wanted column C you would change it to a 2

Sub xmas2()
    Dim LstRw As Long, xRow As Long

    LstRw = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False

    For xRow = LstRw To 2 Step -1
        If Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).Offset(, [COLOR="#0000CD"][B]1[/B][/COLOR]).Value <> 1 Then
            Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).Offset(1).EntireRow.Resize(Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).Offset(, [COLOR="#0000CD"][B]1[/B][/COLOR]).Value - 1).Insert
            Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).AutoFill Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).Resize(Cells(xRow, [COLOR="#FF0000"][B]1[/B][/COLOR]).Offset(, [COLOR="#0000CD"][COLOR="#0000CD"][B]1[/B][/COLOR][/COLOR]).Value), Type:=xlFillSeries
        End If
    Next

    Application.ScreenUpdating = True
End Sub

The "A" in the line below needs changing to whatever the "SN" column is

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

So finally with "SN" being column "B" and "Qtty" being column D you would get...

Sub xmas2()
    Dim LstRw As Long, xRow As Long

    LstRw = Range("B" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False

    For xRow = LstRw To 2 Step -1
        If Cells(xRow, "B").Offset(, 2).Value <> 1 Then
            Cells(xRow, "B").Offset(1).EntireRow.Resize(Cells(xRow, "B").Offset(, 2).Value - 1).Insert
            Cells(xRow, "B").AutoFill Cells(xRow, "B").Resize(Cells(xRow, "B").Offset(, 2).Value), Type:=xlFillSeries
        End If
    Next

    Application.ScreenUpdating = True
End Sub

 

[lolamir]

Excellent..thank youuuuuuu..

in the code below the red 1's are the column references (which i could/should have written as

cells(xrow,"a")

which you probably would have understood better) so you make the 1 either 2 or "b" for the "sn" column if you wanted it to be column b.

The blue 1 is how many columns to the right the "qtty" column is compared to the "sn" column.
So for instance if your "sn" column was a and you wanted column c you would change it to a 2

sub xmas2()
    dim lstrw as long, xrow as long

    lstrw = range("a" & rows.count).end(xlup).row
    application.screenupdating = false

    for xrow = lstrw to 2 step -1
        if cells(xrow, 1).offset(, 1).value <> 1 then
            cells(xrow, 1).offset(1).entirerow.resize(cells(xrow, 1).offset(, 1).value - 1).insert
            cells(xrow, 1).autofill cells(xrow, 1).resize(cells(xrow, 1).offset(, 1).value), type:=xlfillseries
        end if
    next

    application.screenupdating = true
end sub

the "a" in the line below needs changing to whatever the "sn" column is

lstrw = range("a" & rows.count).end(xlup).row

so finally with "sn" being column "b" and "qtty" being column d you would get...

sub xmas2()
    dim lstrw as long, xrow as long

    lstrw = range("b" & rows.count).end(xlup).row
    application.screenupdating = false

    for xrow = lstrw to 2 step -1
        if cells(xrow, "b").offset(, 2).value <> 1 then
            cells(xrow, "b").offset(1).entirerow.resize(cells(xrow, "b").offset(, 2).value - 1).insert
            cells(xrow, "b").autofill cells(xrow, "b").resize(cells(xrow, "b").offset(, 2).value), type:=xlfillseries
        end if
    next

    application.screenupdating = true
end sub

 

[MARK858]

You're welcome.

Btw you don't need to quote whole posts as it just takes up thread space and makes it more difficult to read.
Either just reply or if you have had multiple posters replying just use something like @MARK858.

Try and restrict the use of quotes to only when you need to quote and even then edit it so it only has the relevant parts.