creating a sequence from a list of codes and values

[danno79]

I'm trying to write some VBA code to do the following (don't think its possible using formulas only). In column A i have a list of codes (A1:A32) in column B i have a value (between 1 and 32 in this case, but feasibly could be any integer) I am trying to achive an output in column C which would take the code from col A and then "count up to" the value in col B;- for example "AAA" in col A, and "4" in column B would return AAA1, AAA2, AAA3, AAA4 in column C. For the next code say BBB and corresponding value, would start its sequence in the next empty cell below AAA4 in col C. Any help greatly appreciated.

 

[VoG]

Assuming that column C is initially empty try

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
    For j = 1 To Range("B" & i).Value
        Range("C" & Rows.Count).End(xlUp).Offset(1).Value = Range("A" & i).Value & j
    Next j
Next i
Range("C1").Delete shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub

 

[MickG]

Hi, Another alternative !!

[COLOR="Navy"]Sub[/COLOR] MG29Oct37
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n, Ray(), tot [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Dim[/COLOR] Last [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
tot = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    ReDim Ray(1 To Dn.Offset(, 1))
    [COLOR="Navy"]For[/COLOR] n = 1 To Dn.Offset(, 1)
        Ray(n) = Dn & n
    [COLOR="Navy"]Next[/COLOR] n
Cells(tot, "C").Resize(n - 1).Value = Application.Transpose(Ray)
    tot = tot + n - 1
Erase Ray
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[danno79]

works perfectly thanks - could you give me some pointers as to how integrate colouring the background of the cells according to the bkg colour of cell in col A? would this have to be done with copy-paste?

 

[VoG]

Try

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
    For j = 1 To Range("B" & i).Value
        With Range("C" & Rows.Count).End(xlUp).Offset(1)
            .Value = Range("A" & i).Value & j
            .Interior.ColorIndex = Range("A" & i).Interior.ColorIndex
        End With
    Next j
Next i
Range("C1").Delete shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub

 

[danno79]

VoG - to clear the contents of col c first would i add this?

ActiveSheet.Column("c").ClearContents

 

[danno79]

OK i worked it out for myself;-

ActiveSheet.Range("C1:C32").ClearContents

works fine. Now i'm trying to modify it so that the starting row is 7(or any other row for that matter). (i've worked out how to change the destination column o.k) but now i'm pretty stumped...

 

[VoG]

Try

Sub test()
Dim LR As Long, i As Long, j As Long
Application.ScreenUpdating = False
Columns("C").ClearContents
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 7 To LR
    For j = 1 To Range("B" & i).Value
        With Range("C" & Rows.Count).End(xlUp).Offset(1)
            .Value = Range("A" & i).Value & j
            .Interior.ColorIndex = Range("A" & i).Interior.ColorIndex
        End With
    Next j
Next i
Range("C1").Delete shift:=xlShiftUp
Application.ScreenUpdating = True
End Sub

 

[danno79]

Hi, Another alternative !!

[COLOR=Navy]Sub[/COLOR] MG29Oct37
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n, Ray(), tot [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]Dim[/COLOR] Last [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
tot = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    ReDim Ray(1 To Dn.Offset(, 1))
    [COLOR=Navy]For[/COLOR] n = 1 To Dn.Offset(, 1)
        Ray(n) = Dn & n
    [COLOR=Navy]Next[/COLOR] n
Cells(tot, "C").Resize(n - 1).Value = Application.Transpose(Ray)
    tot = tot + n - 1
Erase Ray
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Mick - been playing with your code - how can i change this so that the "code" column and "count" coulumns are not adjacent to each other? also tried adding VoGs method of changing background colour but without success. Any suggestions?

 

[VoG]

My code worked when I tested it with manually coloured cells.

If the cells are coloured using conditional formatting my code won't copy the CF colours.