# Macro to create a list

#### Marc L

##### Excel Ninja
Hi,​
According to your picture well explain the result for 'red' !​
As concise not matches here working with arrays so do you prefer concise or arrays ?‼​
You must elaborate what means « The code needs to be able to deal with numerical values as well for other data sets. »​
What have you started on your side ? Share your code …​
Attach at least a sample workbook !​

#### francklouis

##### New Member
I need to make a single list using the information in the first two columns of data.
Yes I prefer an array type solution.
The code I have so far will result in a heavy non-concise coding solution. So I have not pursued any further.

>>> use code - tags <<<
Code:
``````For i = 4 To Cells(4, 3).Value + 3

Cells(i, 7).Value = Cells(4, 2).Value
Next i``````

Last edited by a moderator:

#### Kenneth Hobson

##### Active Member
Code:
``````'=xdupsv(A2:A11)
Function xDupsV(fCol As Range, Optional offsetCol As Integer = 1)
Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, sNum As Long, i As Long, j As Long

Application.Volatile True

Set r1 = fCol
Set r2 = r1.Offset(, offsetCol)
ReDim a(1 To 1)

For Each c In r1
Set cc = c.Offset(, offsetCol)
If Not IsEmpty(c) And cc > 0 Then
For j = 1 To cc
i = i + 1
ReDim Preserve a(1 To i)
a(i) = c
Next j
End If
Next c

xDupsV = WorksheetFunction.Transpose(a)
End Function

Sub Test_xDupsV()
Dim a
a = xDupsV([a2])
MsgBox Join(a, vbCrLf)
End Sub``````

#### YasserKhalil

##### Well-Known Member
Try
Code:
``````Sub Test()
Dim c As Range, r As Range, cnt As Integer
Set r = Range("D1")
For Each c In Range("A2:A5").Rows
cnt = c.Offset(, 1).Value
r.Resize(cnt, 1).Value = c.Value
Set r = r.Offset(cnt, 0)
Next c
End Sub``````

• francklouis

#### francklouis

##### New Member
Code:
``````'=xdupsv(A2:A11)
Function xDupsV(fCol As Range, Optional offsetCol As Integer = 1)
Dim a, r1 As Range, r2 As Range, c As Range, cc As Range, sNum As Long, i As Long, j As Long

Application.Volatile True

Set r1 = fCol
Set r2 = r1.Offset(, offsetCol)
ReDim a(1 To 1)

For Each c In r1
Set cc = c.Offset(, offsetCol)
If Not IsEmpty(c) And cc > 0 Then
For j = 1 To cc
i = i + 1
ReDim Preserve a(1 To i)
a(i) = c
Next j
End If
Next c

xDupsV = WorksheetFunction.Transpose(a)
End Function

Sub Test_xDupsV()
Dim a
a = xDupsV([a2])
MsgBox Join(a, vbCrLf)
End Sub``````
Hi Kenneth,
Thanks for the code.
I am having a little trouble implementing the code and getting a runtime error 5.
Can you give me a quick explaination of how to use this code in my spreadsheet.
Does the code adjust automatically as new entries are made in the input columns?

Thanks again

#### francklouis

##### New Member
Try
Code:
``````Sub Test()
Dim c As Range, r As Range, cnt As Integer
Set r = Range("D1")
For Each c In Range("A2:A5").Rows
cnt = c.Offset(, 1).Value
r.Resize(cnt, 1).Value = c.Value
Set r = r.Offset(cnt, 0)
Next c
End Sub``````
Thanks for the nice concise code Yasser.
Is there any way to make the code dynamic so that if more entries are added in the input columns, the code will still work.

thanking you

#### Kenneth Hobson

##### Active Member
I don't see how it would error. Maybe you used some data type other than what you posted. e.g. B2 = 1.3 or maybe B5 = -3. Obviously, I did not code for that as it makes no sense. Or, you did not put the macros into a Module.

My routine is like a dynamic array without the need to actually select the whole range and then enter the formula and then Alt+Ctrl+Shift+Enter. Use it like the new =Sort() and =Unique. Those and mine dynamically update every time that a calculation event occurs. e.g. Any cell value is manually changed on the worksheet that used my UDF.

1. Obviously, the UDF macro would be global/public so store in a Module.
2. Just add the formula as I commented to any cell. I would suggest maybe C2 if columns are A,B,C as inferred from post #1 but it all depends on what you want.
a. Obviously, change A2:A11 to your data. I would suggest maybe A2:A100 even if you just have A2:A11 range filled.
3. Add a 2nd input for the offset column (number to repeat) IF it is not the "1" column to the right as optionally preset for you.

Last edited:

#### YasserKhalil

##### Well-Known Member
To make it dynamic replace this line
Code:
``For Each c In Range("A2:A5").Rows``
with this line
Code:
``For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Rows``

#### francklouis

##### New Member
To make it dynamic replace this line
Code:
``For Each c In Range("A2:A5").Rows``
with this line
Code:
``For Each c In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Rows``
Wow, exactly what I was looking for Yasser! Thanks for the great coding

• YasserKhalil

#### Attachments

• 16.6 KB Views: 3