Complicated transpose

[SeanDamnit]

Hello,

I was hoping to get a little help with a complicated transpose. I have data that looks like this:

---APA7373KT---APA9292KT---APA9292WT...
ALBN1PO248---5---1---9...
ALBN1PO249---3---1---1...
ALBN2PO224---4---5---0...
.
.
.

and I would like it to look like this:
ALBN1PO248---APA7373KT---5---APA9292KT---1---APA9292WT---9...
ALBN1PO249---APA7373KT---3---APA9292KT---1---APA9292WT---1...
ALBN2PO224---APA7373KT---4---APA9292KT---5---APA9292WT---0...
.
.
.

The source file will always have a varying amount of data both left to right and top to bottom, so any script used will have to adapt to that. Unfortunately I'm not completely familiar with VBS yet, so I'm not sure where to begin here.

If anyone is so kind as to help me out, please add comments to some of the VBS lines so I can understand why certain steps are used...(that'll make it so I won't have to bug all of you as much )

 

[hiker95]

SeanDamnit,


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B	C	D
1		APA7373KT	APA9292KT	APA9292WT
2	ALBN1PO248	5	1	9
3	ALBN1PO249	3	1	1
4	ALBN2PO224	4	5	0
5
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D	E	F	G
1	ALBN1PO248	APA7373KT	5	APA9292KT	1	APA9292WT	9
2	ALBN1PO249	APA7373KT	3	APA9292KT	1	APA9292WT	1
3	ALBN2PO224	APA7373KT	4	APA9292KT	5	APA9292WT	0
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
Option Base 1
Sub ReorgData()
' hiker95, 08/16/2011
' http://www.mrexcel.com/forum/showthread.php?t=572298
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, LC As Long, r As Long, c As Long, d As Long
Dim I(), O()
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
LR = w1.Cells(Rows.Count, 1).End(xlUp).Row
LC = w1.Cells(1, Columns.Count).End(xlToLeft).Column
I = w1.Range(w1.Cells(1, 1), w1.Cells(LR, LC))
ReDim O(1 To LR - 1, 1 To ((LC - 1) * 2) + 1)
For r = 2 To UBound(I)
  O(r - 1, 1) = I(r, 1)
  d = 1
  For c = 2 To LC Step 1
    d = d + 1
    O(r - 1, d) = I(1, c)
    d = d + 1
    O(r - 1, d) = I(r, c)
  Next c
Next r
wR.Range("A1").Resize(UBound(O), (LC - 1) * 2 + 1) = O
wR.UsedRange.Columns.AutoFit
wR.Activate
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


Then run the ReorgData macro.

 

[SeanDamnit]

good stuff hiker95, worked perfectly. much appreciated.

 

[hiker95]

SeanDamnit,

You are very welcome.

Glad I could help.

Thanks for the feedback.

Come back anytime.

 

[SeanDamnit]

One more layer of complication, if possible:

I need blank items removed from the transpose. Or in other words:

Data set looks like this:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Row Labels	APA7373KT	APA9292KT	APA9292WT	APX515CKT	ATP515CKIT	LG670KIT	LG670PPKIT
2	ALBN1PO248	5				1
3	ALBN1PO249			1
4	ALTA1PO181			3				1
5	BERK1PO154		2
6	BRAS2PO172		8	6			3
7	BRID1PO37						3
8	BRKL2PO9		3	5	3
9	BUCK1PO172			1			1	4
10	COVE1PO298		4	3	1
Sheet1

I would like it to look like this:

Excel Workbook
	A	B	C	D	E	F	G
1	ALBN1PO248	APA7373KT	5	ATP515CKIT	1
2	ALBN1PO249	APA9292WT	1
3	ALTA1PO181	APA9292WT	3	LG670PPKIT	1
4	BERK1PO154	APA9292KT	2
5	BRAS2PO172	APA9292KT	8	LG670KIT	3
6	BRID1PO37	LG670KIT	3
7	BRKL2PO9	APA9292KT	3	APA9292WT	5	APX515CKT	3
8	BUCK1PO172	APA9292WT	1	LG670KIT	1	LG670PPKIT	4
9	COVE1PO298	APA9292KT	4	APA9292WT	3	APX515CKT	1
Results

If that's not practical please let me know. Thanks!

 

[hiker95]

SeanDamnit,


Sample raw data in worksheet Sheet1:

Excel Workbook
	A	B	C	D	E	F	G	H
1	Row Labels	APA7373KT	APA9292KT	APA9292WT	APX515CKT	ATP515CKIT	LG670KIT	LG670PPKIT
2	ALBN1PO248	5				1
3	ALBN1PO249			1
4	ALTA1PO181			3				1
5	BERK1PO154		2
6	BRAS2PO172		8	6			3
7	BRID1PO37						3
8	BRKL2PO9		3	5	3
9	BUCK1PO172			1			1	4
10	COVE1PO298		4	3	1
11
Sheet1

After the macro in a new worksheet Results:

Excel Workbook
	A	B	C	D	E	F	G
1	ALBN1PO248	APA7373KT	5	ATP515CKIT	1
2	ALBN1PO249	APA9292WT	1
3	ALTA1PO181	APA9292WT	3	LG670PPKIT	1
4	BERK1PO154	APA9292KT	2
5	BRAS2PO172	APA9292KT	8	APA9292WT	6	LG670KIT	3
6	BRID1PO37	LG670KIT	3
7	BRKL2PO9	APA9292KT	3	APA9292WT	5	APX515CKT	3
8	BUCK1PO172	APA9292WT	1	LG670KIT	1	LG670PPKIT	4
9	COVE1PO298	APA9292KT	4	APA9292WT	3	APX515CKT	1
10
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).

Option Explicit
Option Base 1
Sub ReorgDataV2()
' hiker95, 08/17/2011
' http://www.mrexcel.com/forum/showthread.php?t=572298
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, LC As Long, r As Long, c As Long, d As Long
Dim I(), O()
Set w1 = Worksheets("Sheet1")
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
LR = w1.Cells(Rows.Count, 1).End(xlUp).Row
LC = w1.Cells(1, Columns.Count).End(xlToLeft).Column
I = w1.Range(w1.Cells(1, 1), w1.Cells(LR, LC))
ReDim O(1 To LR - 1, 1 To ((LC - 1) * 2) + 1)
For r = 2 To UBound(I)
  O(r - 1, 1) = I(r, 1)
  d = 1
  For c = 2 To LC Step 1
    If I(r, c) = "" Then
      'do nothing
    Else
      d = d + 1
      O(r - 1, d) = I(1, c)
      d = d + 1
      O(r - 1, d) = I(r, c)
    End If
  Next c
Next r
wR.Range("A1").Resize(UBound(O), (LC - 1) * 2 + 1) = O
wR.UsedRange.Columns.AutoFit
wR.Activate
End Sub

Then run the ReorgDataV2 macro.

 

[SeanDamnit]

hiker95, I could kiss you if you weren't a meaningless series of 1s and 0s

 

[hiker95]

SeanDamnit,

Glad I could help.

Come back anytime.

 

[SeanDamnit]

hiker95

I wanted to thank you for helping me with this macro - it's served me well for the last 6 or so months. I was hoping you could help me tweak this further to make the entire process more user friendly, as the task that this macro simplifies is moving to a very un-tech savvy individual.

Anyway...

This is the raw data that I start with, pulled right out of our sales/crm system. I've color coded the 3 relevant data point:
http://www.box.com/s/xn444yiry0c549n0247p

This is how I'd like the data to look after processed, again color coded:
http://www.box.com/s/hayq7q3h0k0fivyc4487

Note that in the orange hi-lighted Coulmn B, there is a vlookup in place that references another sheet:
http://www.box.com/s/fmed62choz1uxgbp8bjl

My hope is that I can tell the owner of this process that all he needs to do is download the data, open the reference document that feeds Column B, and click GO on a macro. Is this practical?

 

[hiker95]

SeanDamnit,


Because of the size and complexity of your latest data I am not displaying screenshots.

See the instructions in BOLD in the below code, in case you have to change the file path, name(s), and, worksheet names.


This macro created a new worksheet Results, that contains the results you were looking for, in 0.340 seconds.



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).

Option Explicit
Sub ReorgDataV3()
' hiker95, 02/29/2011
' http://www.mrexcel.com/forum/showthread.php?t=572298
Dim w1 As Worksheet, wT As Worksheet, wR As Worksheet, wB As Worksheet
Dim wbp As Workbook
Dim a() As Variant, b() As Variant
Dim r As Long, lr As Long, nr As Long, rr As Long, n As Long, nc As Long, fr As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")

'**********
' Change the full path, and name of the file, that contians the "brightpointref" workbook
' Workbooks.Open Filename:="C:\TestData\brightpointref.xlsx"
'**********
Workbooks.Open Filename:="C:\TestData\brightpointref.xlsx"

'**********
' Change the file name, that contians the "brightpointref" workbook
' Set wbp = Workbooks("brightpointref.xlsx")
'**********
Set wbp = Workbooks("brightpointref.xlsx")

'**********
' Change the file name and worksheet name that contains the "brightpointref" raw data, columns A and B
' Set wB = Workbooks("brightpointref.xlsx").Worksheets("Sheet1")
'**********
Set wB = Workbooks("brightpointref.xlsx").Worksheets("Sheet1")

wB.ShowAllData
lr = wB.Cells(Rows.Count, 1).End(xlUp).Row
a = wB.Range("A1:A" & lr)
b = wB.Range("B1:B" & lr)
Application.DisplayAlerts = False
wbp.Close
Application.DisplayAlerts = True
If Not Evaluate("ISREF(hiker95!A1)") Then Worksheets.Add(After:=w1).Name = "hiker95"
Set wT = Worksheets("hiker95")
wT.UsedRange.Clear
w1.UsedRange.Copy wT.Cells(1, 1)
lr = wT.Cells(Rows.Count, 5).End(xlUp).Row
For r = lr To 1 Step -1
  If wT.Cells(r, 5) = "Total:" Or wT.Cells(r, 5) = "" Then wT.Rows(r).Delete
Next r
wT.Columns("L:V").Delete
wT.Columns("I:J").Delete
wT.Columns("B:G").Delete
lr = wT.Cells(Rows.Count, 1).End(xlUp).Row
wT.Range("A2:C" & lr).Sort key1:=wT.Range("A2"), order1:=1, key2:=wT.Range("C2"), order1:=1
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
nr = 2
For r = 2 To lr
  n = Application.CountIf(wT.Columns(1), wT.Cells(r, 1).Value)
  wR.Cells(nr, 1) = wT.Cells(r, 1)
  fr = 0
  On Error Resume Next
  fr = Application.Match(Left(wT.Cells(r, 1), 5), a, 0)
  On Error GoTo 0
  wR.Cells(nr, 2) = b(fr, 1)
  nc = 3
  If n = 1 Then
    wR.Cells(nr, 3) = wT.Cells(r, 3)
    wR.Cells(nr, 4) = wT.Cells(r, 2)
  Else
    For rr = r To r + n - 1
      wR.Cells(nr, nc) = wT.Cells(r, 3)
      wR.Cells(nr, nc + 1) = wT.Cells(r, 2)
      nc = nc + 2
    Next rr
  End If
  r = r + n - 1
  nr = nr + 1
Next r
nc = wR.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
wR.Cells(1, 1) = 1
With wR.Range(wR.Cells(1, 2), wR.Cells(1, nc))
  .FormulaR1C1 = "=RC[-1]+1"
  .Value = .Value
End With
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.DisplayAlerts = False
wT.Delete
Application.DisplayAlerts = True
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


Then run the ReorgDataV3 macro.