Duplicate rows based on call value and and extra column

[arendberg]

Hey Guys,

Would love some help with the below sheets. I want to duplicate the rows in the Input sheet based on the number of adults and childeren, columns C and D. For every duplicated row there needs to be an extra column showing "Adult" for every adult and "Child" for every child.

Input example

Example.xlsx
	A	B	C	D	E	F	G	H
1	arrival	departure	children	adults	travel_purpose	nationality	date_of_birth	country
2	1/21/24	1/26/24	0	2	private_trip	CH	7/12/90	CH
3	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH
4	1/22/24	1/27/24	0	1	private_trip	CH	11/2/90	CH
5	1/22/24	2/3/24	1	3	private_trip	CH	2/7/54	CH
6	1/22/24	1/24/24	0	1	private_trip	CH	3/20/94	CH
Input

Output example

Example.xlsx
	A	B	C	D	E	F	G	H	I
1	arrival	departure	children	adults	travel_purpose	nationality	date_of_birth	country	Class
2	1/21/24	1/26/24	0	2	private_trip	CH	7/12/90	CH	Adult
3	1/21/24	1/26/24	0	2	private_trip	CH	7/12/90	CH	Adult
4	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Adult
5	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Adult
6	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Adult
7	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Adult
8	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Child
9	1/22/24	1/26/24	2	4	private_trip	DE	5/9/79	CH	Child
10	1/22/24	1/27/24	0	1	private_trip	CH	11/2/90	CH	Adult
11	1/22/24	2/3/24	1	3	private_trip	CH	2/7/54	CH	Adult
12	1/22/24	2/3/24	1	3	private_trip	CH	2/7/54	CH	Adult
13	1/22/24	2/3/24	1	3	private_trip	CH	2/7/54	CH	Adult
14	1/22/24	2/3/24	1	3	private_trip	CH	2/7/54	CH	Child
15	1/22/24	1/24/24	0	1	private_trip	CH	3/20/94	CH	Adult
Output

 

[skillilea]

Can you use an actual table or do you need to keep it in a range?

 

[arendberg]

Can you use an actual table or do you need to keep it in a range?

Not sure what you mean? The original data I am using is the whole sheet so not a couple of columns.

 

[arendberg]

Not sure what you mean? The original data I am using is the whole sheet so not a couple of columns.

The results in the output sheet can be in any form that works. After I have the results I will map them in the correct order on another sheet.

 

[skillilea]

OK, see if this works for you

Public Sub ExtendRows()
    Dim ws As Worksheet
    Dim i As Long, x As Long, recCnt As Long
    Dim rng As Range, destRng As Range, cell As Range
    Dim adultCnt As Integer, childCnt As Integer

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet11") ' sheet
    Set rng = ws.Range("A1").CurrentRegion
    Set cell = rng.Cells(1)
    Set destRng = ws.Range("M1")
    
    destRng.CurrentRegion.ClearContents
    
    For i = 1 To rng.Rows.Count
        adultCnt = cell.Offset(i, 3).Value
        childCnt = cell.Offset(i, 2).Value
             
        If adultCnt > 0 Then
            For x = 1 To adultCnt
                WriteRecord destRng, rng, recCnt, i, "Adult"
                recCnt = recCnt + 1
            Next
        End If
        
        If childCnt > 0 Then
            For x = 1 To childCnt
                WriteRecord destRng, rng, recCnt, i, "Child"
                recCnt = recCnt + 1
            Next
        End If
    Next

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Set ws = Nothing
End Sub

Private Sub WriteRecord(destRng As Range, rng As Range, recCnt As Long, rowNum As Long, theClass As String)
    destRng.Offset(recCnt, 0) = rng.Offset(rowNum, 0).Value
    destRng.Offset(recCnt, 1) = rng.Offset(rowNum, 1).Value
    destRng.Offset(recCnt, 2) = rng.Offset(rowNum, 2).Value
    destRng.Offset(recCnt, 3) = rng.Offset(rowNum, 3).Value
    destRng.Offset(recCnt, 4) = rng.Offset(rowNum, 4).Value
    destRng.Offset(recCnt, 5) = rng.Offset(rowNum, 5).Value
    destRng.Offset(recCnt, 6) = rng.Offset(rowNum, 6).Value
    destRng.Offset(recCnt, 7) = rng.Offset(rowNum, 7).Value
    destRng.Offset(recCnt, 8) = rng.Offset(rowNum, 8).Value
    destRng.Offset(recCnt, 9) = theClass
End Sub

 

[arendberg]

Wow amazing, almost where I want to be!
Many thanks.

Only issue is that it puts the result in the same sheet and I need it in a new sheet? And if I need to use it on a sheet that has for instance 20 columns I just increase these I guess?
destRng.Offset(recCnt, 8) = rng.Offset(rowNum, 8).Value - So I would just add multiple lines with higher numbers as long as I keep theClass line as the last one?

 

[skillilea]

Correct, you can add more columns by extending the write record function.

This will allow you to copy data to another sheet, just set it where you want.

Public Sub ExtendRows()
    Dim ws As Worksheet, wsDest As Worksheet
    Dim i As Long, x As Long, recCnt As Long
    Dim rng As Range, destRng As Range, cell As Range
    Dim adultCnt As Integer, childCnt As Integer

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet11") ' sheet
    Set wsDest = ThisWorkbook.Sheets("Sheet12") ' your other sheet
    Set rng = ws.Range("A1").CurrentRegion
    Set cell = rng.Cells(1)
    Set destRng = wsDest.Range("A1") ' change where you want the data
    
    ' if you want to keep headers this needs to change a bit
    destRng.CurrentRegion.ClearContents
    
    For i = 1 To rng.Rows.Count
        adultCnt = cell.Offset(i, 3).Value
        childCnt = cell.Offset(i, 2).Value
             
        If adultCnt > 0 Then
            For x = 1 To adultCnt
                WriteRecord destRng, rng, recCnt, i, "Adult"
                recCnt = recCnt + 1
            Next
        End If
        
        If childCnt > 0 Then
            For x = 1 To childCnt
                WriteRecord destRng, rng, recCnt, i, "Child"
                recCnt = recCnt + 1
            Next
        End If
    Next

    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Set ws = Nothing
    Set wsDest = Nothing
End Sub

 

[skillilea]

How many other columns do you have?
Rows in the dataset?

If the macro is slow. We can change it to either an Array or write a row at a time instead of cell by cell.

 

[arendberg]

I get this error with your new vba? Max 500 rows and columns 14.

 

[arendberg]

This error