Convert row into multiple rows of data (ARRAYS)

[dek]

Hi,

I attach a spreadsheet named "sample" with sample source data and the desired result

Overview
I have established in outlook a custom meeting form to capture event data like attendees and attendee companies along with date of event, internal contacts, etc. Please see sample file.

Definitions
Attendee 1 -> Attendee 10 means attendees that have been invited to an event. All fields may be populated or only some
Company 1 -> Company 10 means the organisation that attendee works for. All fields may be populated or only some.
Required Attendees means internal staff and is always separated by a ";"
Subject is self explanatory
Date is self explanatory


Goal
I would like to list the data into a tabular form as outlined in the sample under "Goal / Output Required".

I can then do pivot tables / reporting on this data very easily.

Assistance Required
I require assistance with the VBA code to generate the "output required".

Many thanks in advance for the help,
dek

[mdmackillop]

Hi Dek,
Welcome to VBAX
Nice clear question!



Option Explicit
Sub Allocate()
Dim rng As Range
Dim tgt As Range
Dim cel As Range
Dim Srce As Range
Dim Nmes, n
Dim att As String, Com As String
Dim Col As Long

Application.ScreenUpdating = False
Set rng = Range(Cells(4, 22), Cells(Rows.Count, 22).End(xlUp))
For Each cel In rng
For Col = 2 To 20 Step 2
If Cells(cel.Row, Col) <> "" Then
att = Cells(cel.Row, Col)
Com = Cells(cel.Row, Col + 1)
Set Srce = Cells(cel.Row, 1)

Nmes = Split(cel, ";")
For Each n In Nmes
Set tgt = Cells(Rows.Count, 1).End(xlUp).Offset(1)
tgt.Offset(, 0) = Srce.Offset(, 0)
tgt.Offset(, 1) = att
tgt.Offset(, 2) = Com
tgt.Offset(, 3) = n
tgt.Offset(, 4) = Srce.Offset(, 23)
tgt.Offset(, 5) = Srce.Offset(, 24)
Next
End If
Next
Next
Application.ScreenUpdating = True
End Sub

[dek]

mdmackillop,

Firstly, thank you very much for the VBA code. It works perfectly. Secondly, thanks for the feedback on the question.

I would like to request one final addition to the code if possible.
Can the results be generated in a seperate sheet named "Output"?

I would like to keep the source separate from the result as the source data will be quite lengthy (approx 1,000-2,000 rows a week).

Regards,
dek

[mdmackillop]

No problem. This will create the Output sheet.

Option Explicit
Sub Allocate()
Dim rng As Range
Dim tgt As Range
Dim cel As Range
Dim Srce As Range
Dim Nmes, n
Dim att As String, Com As String
Dim Col As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet


Application.ScreenUpdating = False
Set ws1 = Sheets("Test2") '<======= Change to suit. or maybe ActiveSheet
Set ws2 = Sheets.Add
ws2.Name = "Output"
ws2.Range("A1:F1") = Array("Ref", "Attendee", "Company", "Attendees Required", "Subject", "Date Start")
ws2.Range("A1:F1").Font.Bold = True
ws2.Columns(6).NumberFormat = "dd mmm yy"
With ws1
Set rng = Range(.Cells(4, 22), .Cells(Rows.Count, 22).End(xlUp))
For Each cel In rng
For Col = 2 To 20 Step 2
If .Cells(cel.Row, Col) <> "" Then
att = .Cells(cel.Row, Col)
Com = .Cells(cel.Row, Col + 1)
Set Srce = .Cells(cel.Row, 1)

Nmes = Split(cel, ";")
For Each n In Nmes
Set tgt = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
tgt.Offset(, 0) = Srce.Offset(, 0)
tgt.Offset(, 1) = att
tgt.Offset(, 2) = Com
tgt.Offset(, 3) = n
tgt.Offset(, 4) = Srce.Offset(, 23)
tgt.Offset(, 5) = Srce.Offset(, 24)
Next
End If
Next
Next
End With
Application.ScreenUpdating = True
End Sub

[dek]

Hi Again mdmackillop,

Change of Scope
I wish I put a bit more consideration in before submitting and having absorbed your time. Unfortunately, I have one last (i promise) change to the scope. Would you assist again?

Additional Contacts
A new column of "Outlook Contacts" (which is a master list of contacts from Outlook) has been inserted with a ";" as a separator.

Unchanged
The original Attendee columns (from 1 - 10) and respective elements to the Attendee (Company and Channel) are unchanged.

The "Atttendees Required" is unchanged in format.

Overall Goal
The end goal is unchanged in that each "Attendee Required" needs the "Attendees" and "Outlook Contacts" to be populated with respective elements (i.e Company and Channel).

The "Outlook Contacts" company and channel information is in a separate sheet named "Master List".

Please see the "Goal" section of the sample file attached.

dek

[dek]

Hi,

I would like to learn. If you can comment each line, that would be greatly appreciated so that I can move forward and hopefully post replies to assist other users in this forum.

Thx.

[dek]

Hi Again mdmackillop,

Change of Scope
I wish I put a bit more consideration in before submitting and having absorbed your time. Unfortunately, I have one last (i promise) change to the scope. Would you assist again?

Additional Contacts
A new column of "Outlook Contacts" (which is a master list of contacts from Outlook) has been inserted with a ";" as a separator.

Unchanged
The original Attendee columns (from 1 - 10) and respective elements to the Attendee (Company and Channel) are unchanged.

The "Atttendees Required" is unchanged in format.

Overall Goal
The end goal is unchanged in that each "Attendee Required" needs the "Attendees" and "Outlook Contacts" to be populated with respective elements (i.e Company and Channel).

The "Outlook Contacts" company and channel information is in a separate sheet named "Master List".

Please see the "Goal" section of the sample file attached.

dek