Duplicating text based on a cell value

[ma0ffst08]

Hello,

I have 4 columns - Names (column A), Total Points (column B), Entries (column C), List of Names (column F).

In column A and B, there will be a list of names and some numbers - the number of names can change, but every name will have a number adjacent in column B

Firstly, please can the following formula be pasted into cell C1, and the copied down for all names and points:
=IF(B2=0,0,IF(B2>=1000,15,IF(B2>=900,10,IF(B2>=800,9,IF(B2>=700,8,IF(B2>=600,7,IF(B2>=500,6,IF(B2>=400,5,IF(B2>=300,4,IF(B2>=200,3,IF(B2>=100,2,1)))))))))))

In column F, I want the macro to generate a list of names.
These names are the same names that are in Column A, but repeated the name number of times as in column C (where we just put the formula)
I have attached a screenshot of what this would look like for a very simple example. In reality there might be up to 400 names.

Thank you all

 

[Georgiboy]

Which version of Excel are you using?

 

[ma0ffst08]

Which version of Excel are you using?

Hi, Office 2019 (version 4)...

 

[Peter_SSs]

Hi, Office 2019

Please put that in your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

 

[Georgiboy]

How about the below:

Sub MultiNames()
    Dim var As Variant, rng As Range, oVar() As Variant, oRng As Range
    Dim x As Long, y As Long, z As Long
    
    Set rng = Range("A2:C5") ' input range (names & points & Entries(even if blank))
    Set oRng = Range("F2") ' output range
    var = rng.Value
    For x = 1 To UBound(var)
        Select Case var(x, 2)
            Case Is >= 1000: var(x, 3) = 15
            Case Is >= 900: var(x, 3) = 10
            Case Is >= 800: var(x, 3) = 9
            Case Is >= 700: var(x, 3) = 8
            Case Is >= 600: var(x, 3) = 7
            Case Is >= 500: var(x, 3) = 6
            Case Is >= 400: var(x, 3) = 5
            Case Is >= 300: var(x, 3) = 4
            Case Is >= 200: var(x, 3) = 3
            Case Is >= 100: var(x, 3) = 2
            Case Is > 0: var(x, 3) = 1
            Case Else: var(x, 3) = 0
        End Select
    Next x
    rng = var
    For x = 1 To UBound(var)
        For y = 0 To var(x, 3) - 1
            ReDim Preserve oVar(z)
            oVar(z) = var(x, 1)
            z = z + 1
        Next y
    Next x
    oRng.Resize(z) = Application.Transpose(oVar)
End Sub

Before:

qqq.xlsm
	A	B	C	D	E	F
1	Names	Total Points	Entries
2	Tom	1
3	John	159
4	Amy	506
5	Margaret	783
6
7
8
9
10
11
12
13
14
15
16
17
18
Sheet1

After:

qqq.xlsm
	A	B	C	D	E	F
1	Names	Total Points	Entries
2	Tom	1	1			Tom
3	John	159	2			John
4	Amy	506	6			John
5	Margaret	783	8			Amy
6						Amy
7						Amy
8						Amy
9						Amy
10						Amy
11						Margaret
12						Margaret
13						Margaret
14						Margaret
15						Margaret
16						Margaret
17						Margaret
18						Margaret
Sheet1

 

[ma0ffst08]

How about the below:

Sub MultiNames()
    Dim var As Variant, rng As Range, oVar() As Variant, oRng As Range
    Dim x As Long, y As Long, z As Long
  
    Set rng = Range("A2:C5") ' input range (names & points & Entries(even if blank))
    Set oRng = Range("F2") ' output range
    var = rng.Value
    For x = 1 To UBound(var)
        Select Case var(x, 2)
            Case Is >= 1000: var(x, 3) = 15
            Case Is >= 900: var(x, 3) = 10
            Case Is >= 800: var(x, 3) = 9
            Case Is >= 700: var(x, 3) = 8
            Case Is >= 600: var(x, 3) = 7
            Case Is >= 500: var(x, 3) = 6
            Case Is >= 400: var(x, 3) = 5
            Case Is >= 300: var(x, 3) = 4
            Case Is >= 200: var(x, 3) = 3
            Case Is >= 100: var(x, 3) = 2
            Case Is > 0: var(x, 3) = 1
            Case Else: var(x, 3) = 0
        End Select
    Next x
    rng = var
    For x = 1 To UBound(var)
        For y = 0 To var(x, 3) - 1
            ReDim Preserve oVar(z)
            oVar(z) = var(x, 1)
            z = z + 1
        Next y
    Next x
    oRng.Resize(z) = Application.Transpose(oVar)
End Sub

Before:

qqq.xlsm
	A	B	C	D	E	F
1	Names	Total Points	Entries
2	Tom	1
3	John	159
4	Amy	506
5	Margaret	783
6
7
8
9
10
11
12
13
14
15
16
17
18
Sheet1

After:

qqq.xlsm
	A	B	C	D	E	F
1	Names	Total Points	Entries
2	Tom	1	1			Tom
3	John	159	2			John
4	Amy	506	6			John
5	Margaret	783	8			Amy
6						Amy
7						Amy
8						Amy
9						Amy
10						Amy
11						Margaret
12						Margaret
13						Margaret
14						Margaret
15						Margaret
16						Margaret
17						Margaret
18						Margaret
Sheet1

Thank you, that is great!

 

[Georgiboy]

You're welcome, thanks for the feedback.

 

[Peter_SSs]

Thanks for updating your version details.

If you are interested, here is another way to achieve the result to your question. The main differences are the much shorter way to populate column C and the elimination of the need to continually ReDim Preserve the array to hold the column F names

Sub Test()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  
  With Range("B2", Range("B" & Rows.Count).End(xlUp))
    .Offset(, 1).Value = Evaluate(Replace("int(#/100)+lookup(#,{0,1,1000},{0,1,5})", "#", .Address))
    a = .Offset(, -1).Resize(, 3).Value
    ReDim b(1 To Application.Sum(.Offset(, 1)), 1 To 1)
  End With
  For i = 1 To UBound(a)
    For j = 1 To a(i, 3)
      k = k + 1: b(k, 1) = a(i, 1)
    Next j
  Next i
  Range("F2").Resize(UBound(b)).Value = b
End Sub