• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Macro to create a list

francklouis

New Member
Hello VBA experts.

Can anyone help with this operation I want to do using VBA.

I want to create the List shown in the photo from the user input data in the first two columns.

The code needs to be able to deal with numerical values as well for other data sets.
I would like the vba code to be concise and using arrays.

Thanks in advance.
74225
 
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 !​
 
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:
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
 
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
 
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
 
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
 
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:
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
 
It's a one-liner in Power Query:
Code:
= Table.RenameColumns(Table.SelectColumns(Table.ExpandListColumn(Table.TransformColumns(Excel.CurrentWorkbook(){[Name="Table1"]}[Content], {{"Q", each {1.._}}}),"Q"),{"color"}),{{"color", "List"}})
Adjust the table on the left (keep the headers as they are) then right-click the right table, choose Refresh.
74275
 

Attachments

  • Chandoo46153.xlsx
    16.6 KB · Views: 7
Back
Top