Transposing data and linking with one criteria

[iellingson]

Thanks in advance for all the help and suggestions that you provide.

I have a need to consolidate the data from rows to columns yet only provide one "master" or "unique" identifier. Example below.

This is how the data is currently presented.

   A           B        C
1  Identifier  Service  Charge
2  5555        1        25
3  5555        2        4.5
4  5555        3        3.5
5  5555        4        1
6  6666        1        35
7  6666        2        5.5
8  6666        3        4.5


This is the format I need it in.

   A           B        C       D        E       F        G       H        I
1  Identifier  Service  Charge  Service  Charge  Service  Charge  Service  Charge
2  5555        1        25      2        4.5     3        3.5     4        1
3  6666        1        35      2        5.5     3        4.5

 

[hiker95]

iellingson,


With your raw data in worksheet Sheet1 already sorted/grouped per your screenshot.

Excel Workbook
	A	B	C
1	Identifier	Service	Charge
2	5555	1	25
3	5555	2	4.5
4	5555	3	3.5
5	5555	4	1
6	6666	1	35
7	6666	2	5.5
8	6666	3	4.5
9
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D	E	F	G	H	I
1	Identifier	Service	Charge	Service	Charge	Service	Charge	Service	Charge
2	5555	1	25	2	4.5	3	3.5	4	1
3	6666	1	35	2	5.5	3	4.5
4
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, by highlighting the code and pressing the keys CTRL + C
2. Open your 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 by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 08/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=569622
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, a As Long, r As Long, SR As Long, ER As Long, NC As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(1), Unique:=True
LR = wR.Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To LR Step 1
  SR = Application.Match(wR.Cells(a, 1), w1.Columns(1), 0)
  ER = Application.Match(wR.Cells(a, 1), w1.Columns(1), 1)
  For r = SR To ER Step 1
    NC = wR.Cells(a, Columns.Count).End(xlToLeft).Column + 1
    wR.Cells(a, NC).Resize(, 2).Value = w1.Cells(r, 2).Resize(, 2).Value
  Next r
Next a
NC = wR.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
For a = 2 To NC Step 2
  wR.Cells(1, a).Resize(, 2).Value = w1.Cells(1, 2).Resize(, 2).Value
Next a
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[iellingson]

iellingson,


With your raw data in worksheet Sheet1 already sorted/grouped per your screenshot.

Excel Workbook
	A	B	C
1	Identifier	Service	Charge
2	5555	1	25
3	5555	2	4.5
4	5555	3	3.5
5	5555	4	1
6	6666	1	35
7	6666	2	5.5
8	6666	3	4.5
9	*	*	*
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D	E	F	G	H	I
1	Identifier	Service	Charge	Service	Charge	Service	Charge	Service	Charge
2	5555	1	25	2	4.5	3	3.5	4	1
3	6666	1	35	2	5.5	3	4.5	*	*
4	*	*	*	*	*	*	*	*	*
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, by highlighting the code and pressing the keys CTRL + C
2. Open your 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 by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 08/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=569622
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, a As Long, r As Long, SR As Long, ER As Long, NC As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(1), Unique:=True
LR = wR.Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To LR Step 1
  SR = Application.Match(wR.Cells(a, 1), w1.Columns(1), 0)
  ER = Application.Match(wR.Cells(a, 1), w1.Columns(1), 1)
  For r = SR To ER Step 1
    NC = wR.Cells(a, Columns.Count).End(xlToLeft).Column + 1
    wR.Cells(a, NC).Resize(, 2).Value = w1.Cells(r, 2).Resize(, 2).Value
  Next r
Next a
NC = wR.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
For a = 2 To NC Step 2
  wR.Cells(1, a).Resize(, 2).Value = w1.Cells(1, 2).Resize(, 2).Value
Next a
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

Thanks for the answer and I guess this is my fault but this absolutely worked for the example I provided. However the spreadsheet I am working with contains 15,061 rows and the macro does not seem to work the same with that much data.

 

[hiker95]

iellingson,

When you reply, it is not ncecssary to copy the entire reply from someone assisting you.


1. What is the worksheet name where your raw data is located?

2. What version of Excel are you using?

You will generally get much more help (and faster) in this forum if you can post your small samples (what you have and what you expect to achieve) directly in the forum.

To attach screenshots, see below in my Signature block: Post a screen shot with one of these:

If you are not able to give us screenshots, see below in my Signature block: You can upload your workbook to Box Net, and provide us with a link to your workbook.

 

[hiker95]

iellingson,


The following macro should be a lot faster becausse of the use of arrays (I am learning how to manipulate data in memory and not in a worksheet).


With your raw data already sorted/grouped per your screenshot.

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Identifier	Service	Charge
2	5555	1	25
3	5555	2	4.5
4	5555	3	3.5
5	5555	4	1
6	6666	1	35
7	6666	2	5.5
8	6666	3	4.5
9
Sheet1

After the macro, in the same worksheet:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Identifier	Service	Charge			Identifier	Service	Charge	Service	Charge	Service	Charge	Service	Charge
2	5555	1	25			5555	1	25	2	4.5	3	3.5	4	1
3	5555	2	4.5			6666	1	35	2	5.5	3	4.5
4	5555	3	3.5
5	5555	4	1
6	6666	1	35
7	6666	2	5.5
8	6666	3	4.5
9
Sheet1

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, by highlighting the code and pressing the keys CTRL + C
2. Open your 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 by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgDataV2()
' hiker95, 08/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=569622
Dim ABC(), F()
Dim A, B, t, u
Dim LR As Long, i As Long, ii As Long, s As Long, e As Long, g As Long
Dim d1 As Object, d2 As Object
LR = Cells(Rows.Count, 1).End(xlUp).Row
ABC = Range("A1:C" & LR)
A = Range("A1:A" & LR)
B = Range("B1:B" & LR)
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For i = 1 To LR
  If Not d1.exists(A(i, 1)) Then d1(A(i, 1)) = d1.Count
  If Not d2.exists(B(i, 1)) Then d2(B(i, 1)) = d2.Count
Next i
u = d1.Keys
ReDim F(1 To d1.Count, 1 To (d2.Count - 1) * 2 + 1)
Range("F1").Resize(LR, (d2.Count - 1) * 2 + 1) = ""
For i = 1 To d1.Count
  F(i, 1) = u(i - 1)
Next i
For i = 2 To (d2.Count - 1) * 2 + 1 Step 2
  F(1, i) = "Service"
  F(1, i + 1) = "Charge"
Next i
t = d1.Keys
For i = 2 To d1.Count
  s = Application.Match(t(i - 1), A, 0)
  e = Application.Match(t(i - 1), A, 1)
  g = 0
  For ii = s To e
    g = g + 2
    F(i, g) = ABC(ii, 2)
    F(i, g + 1) = ABC(ii, 3)
  Next ii
Next i
With Range("F1").Resize(d1.Count, (d2.Count - 1) * 2 + 1)
  .Value = F
  .Columns.AutoFit
End With
End Sub

Then run the ReorgDataV2 macro.