Converting Horizontal Data to Vertical with Intentional Redundancies

[TCheatham]

Hi everyone,

I know there are some similar posts out there, but I’m terrible with understanding macros. Could someone tell me a macro for the following?

Here’s an example data set:

	A	B	C	D	E	F	G	H
1		Date	Status
2	ID	First	Last	Service Group	10/9/2015	10/14/2015	10/21/2015	10/28/2015
3	11111	A	L	Senior Citizens	Present	Present	Present	Absent
4	22222	D	A	Senior Citizens	Present	Present	Present	Present
5	33333	A	A	Senior Citizens	Present	Present	Present	Present
6	44444	H	P	Senior Citizens	Present	Absent	Present	Absent
23
24
25
26
27
28
29	Topic				getting to know each other	played game, did survey	discussed prices in the 30s-70s & 2015, did survey	made posters of 30s-2015

<tbody>
</tbody>

I would like the macro to rearrange the data in a new spreadsheet as follows:

[TABLE="class: grid, width: 563"]
<tbody>[TR]
[TD]
[/TD]
[TD]A
[/TD]
[TD]B
[/TD]
[TD]C
[/TD]
[TD]D
[/TD]
[TD]E
[/TD]
[TD]F
[/TD]
[TD]G
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]Date
[/TD]
[TD]ID
[/TD]
[TD]First
[/TD]
[TD]Last
[/TD]
[TD]Service Group
[/TD]
[TD]Status
[/TD]
[TD]Topic
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]10/9/2015
[/TD]
[TD]11111
[/TD]
[TD]A
[/TD]
[TD]L
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]getting to know each other
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]10/9/2015
[/TD]
[TD]22222
[/TD]
[TD]D
[/TD]
[TD]A
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]getting to know each other
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]10/9/2015
[/TD]
[TD]33333
[/TD]
[TD]A
[/TD]
[TD]A
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]getting to know each other
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]10/9/2015
[/TD]
[TD]44444
[/TD]
[TD]H
[/TD]
[TD]P
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]getting to know each other
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]10/14/2015
[/TD]
[TD]11111
[/TD]
[TD]A
[/TD]
[TD]L
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]played game, did survey
[/TD]
[/TR]
[TR]
[TD]7
[/TD]
[TD]10/14/2015
[/TD]
[TD]22222
[/TD]
[TD]D
[/TD]
[TD]A
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]played game, did survey
[/TD]
[/TR]
[TR]
[TD]8
[/TD]
[TD]10/14/2015
[/TD]
[TD]33333
[/TD]
[TD]A
[/TD]
[TD]A
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Present
[/TD]
[TD]played game, did survey
[/TD]
[/TR]
[TR]
[TD]9
[/TD]
[TD]10/14/2015
[/TD]
[TD]44444
[/TD]
[TD]H
[/TD]
[TD]P
[/TD]
[TD]Senior Citizens
[/TD]
[TD]Absent
[/TD]
[TD]played game, did survey
[/TD]
[/TR]
</tbody>[/TABLE]


I’m looking for a good format for:

-individual groups to record attendance, as well as, weekly topics
-a macro that convert the attendance of all of the groups into vertical data that can then be imported in Access

I intentionally left multiple spaces between the last entry and the topic area because each group will vary in the number of participants. I know that this data could technically go above the date information if that would be easier. On average each group will have 8-12 participants and there will be enough dates for a full school year of weekly or bi-weekly meetings.

Thank you if you can make this work!

 

[JLGWhiz]

Copy this code to your standard code module 1. To access the code module, press Alt + F11 to open the vb editor. If the large pane is dark, then click on Insert in the editor menu bar, then click module and the pane should brighten. Check the title bar at the top of the editor to be sure it says [Module1 (Code)]. Paste the code into the large pane. Close the editor. Save the workbook as a macro enabled workbook (.xlsm).

Note that the code is annotated with comments to edit sheet name. This refers to Sheets(1) and Sheets(2) which are using sheet index numbers. You should replace the index numbers in parentheses with actual sheet names like ("Sheet1") or ("Data"), etc. Those should be the only changes necessary.

Sub rearrange()
Dim sh1 As Worksheet, sh2 As Worksheet, i As Long, c As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
With sh1
    For i = 5 To .Cells(2, Columns.Count).End(xlToLeft).Column
        For Each c In .Range("A3", .Cells(Rows.Count, 1).End(xlUp).Offset(-1))
            If .Cells(c.Row, i) <> "" Then
                sh2.Cells(Rows.Count, 1).End(xlUp)(2) = sh1.Cells(2, i).Value
                c.Resize(1, 4).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1)
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 5) = sh1.Cells(c.Row, i).Value
                sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 6) = sh1.Cells(Rows.Count, i).End(xlUp).Value
            End If
        Next
    Next
End With
End Sub

 

[hiker95]

Tcheatham,

Welcome to the MrExcel forum.

Here is another macro solution for you to consider, that uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns.

You can change the raw data worksheet name in the macro.

The macro will create a new worksheet Results.

Sample raw data:

Excel 2007
	A	B	C	D	E	F	G	H	I
1		Date	Status
2	ID	First	Last	Service Group	10/9/2015	10/14/2015	10/21/2015	10/28/2015
3	11111	A	L	Senior Citizens	Present	Present	Present	Absent
4	22222	D	A	Senior Citizens	Present	Present	Present	Present
5	33333	A	A	Senior Citizens	Present	Present	Present	Present
6	44444	H	P	Senior Citizens	Present	Absent	Present	Absent
7
8
9
10
11
12
13	Topic				getting to know each other	played game, did survey	discussed prices in the 30s-70s & 2015, did survey	made posters of 30s-2015
14
Sheet1

And, after the macro in worksheet Results:

Excel 2007
	A	B	C	D	E	F	G
1	Date	ID	First	Last	Service Group	Status	Topic
2	10/9/2015	11111	A	L	Senior Citizens	Present	getting to know each other
3	10/9/2015	22222	D	A	Senior Citizens	Present	getting to know each other
4	10/9/2015	33333	A	A	Senior Citizens	Present	getting to know each other
5	10/9/2015	44444	H	P	Senior Citizens	Present	getting to know each other
6	10/14/2015	11111	A	L	Senior Citizens	Present	played game, did survey
7	10/14/2015	22222	D	A	Senior Citizens	Present	played game, did survey
8	10/14/2015	33333	A	A	Senior Citizens	Present	played game, did survey
9	10/14/2015	44444	H	P	Senior Citizens	Absent	played game, did survey
10	10/21/2015	11111	A	L	Senior Citizens	Present	discussed prices in the 30s-70s & 2015, did survey
11	10/21/2015	22222	D	A	Senior Citizens	Present	discussed prices in the 30s-70s & 2015, did survey
12	10/21/2015	33333	A	A	Senior Citizens	Present	discussed prices in the 30s-70s & 2015, did survey
13	10/21/2015	44444	H	P	Senior Citizens	Present	discussed prices in the 30s-70s & 2015, did survey
14	10/28/2015	11111	A	L	Senior Citizens	Absent	made posters of 30s-2015
15	10/28/2015	22222	D	A	Senior Citizens	Present	made posters of 30s-2015
16	10/28/2015	33333	A	A	Senior Citizens	Present	made posters of 30s-2015
17	10/28/2015	44444	H	P	Senior Citizens	Absent	made posters of 30s-2015
18
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 06/03/2016, ME945177
Dim w1 As Worksheet, wr As Worksheet
Dim a As Variant, i As Long
Dim lr As Long, lc As Long, c As Long, n As Long, t As Range
Dim o As Variant, j As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")   '<-- you can change the sheet name here
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
With wr
  .UsedRange.Clear
  With .Cells(1, 1).Resize(, 7)
    .Value = Array("Date", "ID", "First", "Last", "Service Group", "Status", "Topic")
    .Font.Bold = True
  End With
End With
With w1
  lr = .Cells(2, 1).End(xlDown).Row
  lc = .Cells(2, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(2, 1), .Cells(lr, lc))
  ReDim o(1 To (lc - 4) * (lr - 2), 1 To 7)
  Set t = .Columns(1).Find("Topic", LookAt:=xlWhole)
End With
For c = 5 To lc
  For i = 2 To UBound(a, 1)
    j = j + 1
    o(j, 1) = a(1, c)
    o(j, 2) = a(i, 1)
    o(j, 3) = a(i, 2)
    o(j, 4) = a(i, 3)
    o(j, 5) = a(i, 4)
    o(j, 6) = a(i, c)
    o(j, 7) = w1.Cells(t.Row, c)
  Next i
Next c
With wr
  .Cells(2, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[hiker95]

Tcheatham,

On average each group will have 8-12 participants

The screenshot of the raw data should have the Topic row in row 29, with some blank rows between the raw data, and, the Topic row.

 

[hiker95]

Tcheatham,

If there are no blank cells in column A, below your title row, to the row that begins with Topic, then here is an updated macro for you to consider.

The updated macro uses two arrays in memory, and, will adjust to the number of raw data rows, and, columns.

You can change the raw data worksheet name in the macro.

The macro will create a new worksheet Results.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ReorgData_V2()
' hiker95, 06/04/2016, ME945177
Dim w1 As Worksheet, wr As Worksheet
Dim a As Variant, i As Long
Dim lr As Long, lc As Long, c As Long, n As Long, t As Range
Dim o As Variant, j As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")   '<-- you can change the sheet name here
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
With wr
  .UsedRange.Clear
  With .Cells(1, 1).Resize(, 7)
    .Value = Array("Date", "ID", "First", "Last", "Service Group", "Status", "Topic")
    .Font.Bold = True
  End With
End With
With w1
  Set t = .Columns(1).Find("Topic", LookAt:=xlWhole)
  lr = .Cells(2, 1).End(xlDown).Row
  If lr = t.Row Then lr = lr - 1
  lc = .Cells(2, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(2, 1), .Cells(lr, lc))
  ReDim o(1 To (lc - 4) * (lr - 2), 1 To 7)
End With
For c = 5 To lc
  For i = 2 To UBound(a, 1)
    j = j + 1
    o(j, 1) = a(1, c)
    o(j, 2) = a(i, 1)
    o(j, 3) = a(i, 2)
    o(j, 4) = a(i, 3)
    o(j, 5) = a(i, 4)
    o(j, 6) = a(i, c)
    o(j, 7) = w1.Cells(t.Row, c)
  Next i
Next c
With wr
  .Cells(2, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns(1).Resize(, UBound(o, 2)).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData_V2 macro.

 

[TCheatham]

Thank you both JLGWhiz & hiker95! The macro does exactly what I need it to do even with a larger dataset. Things like this are what's good about humanity -- thank you each for volunteering your time.

 

[JLGWhiz]

Thank you both JLGWhiz & hiker95! The macro does exactly what I need it to do even with a larger dataset. Things like this are what's good about humanity -- thank you each for volunteering your time.

Thank you for the feedback,
Regards, JLG

 

[hiker95]

Thank you both JLGWhiz & hiker95! The macro does exactly what I need it to do even with a larger dataset. Things like this are what's good about humanity -- thank you each for volunteering your time.

TCheatham,

Thanks for the feedback.

You are very welcome. Glad we could help.

And, come back anytime.