VBA to create the column and populate the value based on a set of data

[Binh Tran]

Dear all,

I have this below data set:

Input data set:

Position	Headcount
A	2
B	3
C	2
D	2
E	4

I would like to use VBA to create another table as below in which it populate value of each position in accordance to the headcount column and when i change the headcount value, the table below will be auto updated. I am new to VBA and so this is too difficult for me. Hope that you can help me on this since i spent half of my day learning without any luck.

Desired output

Position

A

A

B

B

B

C

C

D

D

E

E

E

E

 

[Peter_SSs]

Edit: Sorry, I forgot about the auto-update. I will address that in another post shortly.

Welcome to the MrExcel board!

Assuming your input data is on the active sheet, starting in cell A1, try this with a copy of your workbook. Results come in column D

Sub Position_Head_Count()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  a = Range("A1").CurrentRegion.Value2
  ReDim b(1 To Rows.Count, 1 To 1)
  For i = 2 To UBound(a)
    For j = 1 To a(i, 2)
      k = k + 1
      b(k, 1) = a(i, 1)
    Next j
  Next i
  Range("D1").Value = "Position"
  Range("D2").Resize(k).Value = b
End Sub

My data and results:

Binh Tran.xlsm
	A	B	C	D
1	Position	Headcount		Position
2	A	2		A
3	B	3		A
4	C	2		B
5	D	2		B
6	E	4		B
7				C
8				C
9				D
10				D
11				E
12				E
13				E
14				E
15
Sheet1

 

[Peter_SSs]

when i change the headcount value, the table below will be auto updated.

Try this Worksheet_Change event code. To implement ..
1. Right click the sheet name tab and choose "View Code".
2. Copy and Paste the code below into the main right hand pane that opens at step 1.
3. Close the Visual Basic window & test by altering a value in column A or B.
4. Your workbook will need to be saved as a macro-enabled workbook (*.xlsm).

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  
  If Not Intersect(Target, Columns("A:B")) Is Nothing Then
    a = Range("A1").CurrentRegion.Value2
    ReDim b(1 To Rows.Count, 1 To 1)
    For i = 2 To UBound(a)
      For j = 1 To a(i, 2)
        k = k + 1
        b(k, 1) = a(i, 1)
      Next j
    Next i
    Application.ScreenUpdating = False
    Range("D1", Range("D" & Rows.Count).End(xlUp)).ClearContents
    Range("D1").Value = "Position"
    Range("D2").Resize(k).Value = b
    Application.ScreenUpdating = True
  End If
End Sub

 

[Binh Tran]

Hi Peter,

Thank you very much for your answer. It worked perfectly.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.