Unique list out of non-unique row

[tabibito]

Hello everyone!

mrexcel has been my top resource when it comes to Excel-related questions. Great to be a member now.

What follows is a tricky combination (for me, that is) of
- starting from several rows named "A", "B", ... with blank cells, zeroes and values larger than zero in columns named "1", "1.5", ...
- transposing them into a continuous vertical list of "row name - column name" pairs (e.g. "A" "1")
- leaving out all the blank cells and zeroes.

	1	1,5	2	2,5	3	3,5	4	4,5	5	5.5			A	2.5	1
A			0	1	2		4		0	1			A	3	2
													A	4	4
													A	5.5	1
													B	1	1
B	1	2	0	0	4	5	0	1					B	1.5	2
													B	3	4
													B	3.5	5
													B	4.5	1
C				1	1								C	2.5	1
													C	3	1
													D	1.5	1
													D	2.5	2
D		1	0	2	3	0	1	1	1				D	3	3
													D	4	1
													D	4.5	1
...	...	...	...	...	...	...	...	...	...	...			D	5	1
													...	...	...

<tbody>
</tbody>

What I've tried so far:
(1) Created a helper table with the full range of 1 , 1.5 , 2 , ... , 5 , 5.5, displaying "" for all blanks or zeroes in the upper left chart.
(2) From that, tried to create another helper table displaying only the unique values of the helper table created in (1). This did not work out because the array formula below does not accept formula ""s:
=IFERROR(INDEX($helpertablerange,SMALL(IF(ISBLANK($helpertablerange),"",COLUMN($helpertablerange)-MIN(COLUMN($helpertablerange))+1),COLUMN(C1))),"")
CTRL+SHIFT+ENTER
(3) From that, planned on using INDEX/MATCH combined with the TRANSPOSE function to create the unique list of "ROW LETTER" x "COLUMN NUMBER" x "VALUE" pairs.

I assume this is only one hint for a possible solution to the problem and certainly not the one to the most efficient one.

Any hints leading me towards solving this quiz would be greatly appreciated.

Thank you in advance.

Tabibito

 

[hiker95]

tabibito,

Welcome to the MrExcel forum.

What version of Excel and Windows are you using?


How about a macro solution?


Sample raw data:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1		1	1,5	2	2,5	3	3,5	4	4,5	5	5.5
2	A			0	1	2		4		0	1
3
4
5
6	B	1	2	0	0	4	5	0	1
7
8
9
10	C				1	1
11
12
13
14	D		1	0	2	3	0	1	1	1
15
16
17	...	...	...	...	...	...	...	...	...	...	...
18
19
Sheet1

After the macro:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1		1	1,5	2	2,5	3	3,5	4	4,5	5	5.5			A	2.5	1
2	A			0	1	2		4		0	1			A	3	2
3														A	4	4
4														A	5.5	1
5														B	1	1
6	B	1	2	0	0	4	5	0	1					B	1.5	2
7														B	3	4
8														B	3.5	5
9														B	4.5	1
10	C				1	1								C	2.5	1
11														C	3	1
12														D	1.5	1
13														D	2.5	2
14	D		1	0	2	3	0	1	1	1				D	3	3
15														D	4	1
16														D	4.5	1
17	...	...	...	...	...	...	...	...	...	...	...			D	5	1
18														...	...	...
19
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
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.

Option Explicit
Sub ReorgData()
' hiker95, 01/28/2014, ME753744
Dim oa As Variant, lr As Long, lc As Long, d As Range, h As String
Dim a As Variant, o As Variant, c As Long
Dim i As Long, ii As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
oa = Range(Cells(1, 1), Cells(lr, lc))
For Each d In Range(Cells(1, 1), Cells(1, lc))
  If InStr(d, ",") Then
    h = d
    h = Replace(h, ",", ".")
    d.NumberFormat = "0.0"
    d = h
  End If
Next d
a = Range(Cells(1, 1), Cells(lr, lc))
n = Application.CountIf(Range(Cells(2, 2), Cells(lr - 1, lc)), ">0")
ReDim o(1 To n * 2, 1 To 3)
For i = 2 To UBound(a, 1)
  If a(i, 1) <> "" Then
    For c = 2 To lc
      If a(i, c) > 0 And a(i, c) <> "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = a(1, c)
        o(ii, 3) = a(i, c)
      ElseIf a(i, 1) = "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = "..."
        o(ii, 3) = "..."
        GoTo Continue
      End If
    Next c
  End If
Next i
Continue:
Range("A1").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
lr = Cells(Rows.Count, lc + 3).End(xlUp).Row
Range(Cells(1, lc + 3), Cells(lr, lc + 3)).Font.Bold = True
Columns.AutoFit
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 ReorgData macro.

 

[tabibito]

Dear hiker95,

Your code made my day - I'm amazed. What you gave me is exactly what I was looking for to solve this riddle.

The only reason I tried to get around Macro is that I am not confident with vba. Your macro operates smoothly, fast and the file size remains amazingly small.

I have become interested in learning more about creating macros myself now. First step will be to understand your code, and do some tests with modified versions of it.

Thanks a lot!!

tabibito


P.S.: Thanks for the keyboard shortcuts also, makes operating excel so much smoother.

 

[hiker95]

tabibito,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[tabibito]

Dear hiker95,

while your code worked perfectly on my excel 2010,
it gives me a Subscript out of range (Error 9) when trying to open it from a PC with excel 2007.

Debugging highlights the following red line:

Option Explicit
Sub ReorgData()
' hiker95, 01/28/2014, ME753744
Dim oa As Variant, lr As Long, lc As Long, d As Range, h As String
Dim a As Variant, o As Variant, c As Long
Dim i As Long, ii As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
oa = Range(Cells(1, 1), Cells(lr, lc))
For Each d In Range(Cells(1, 1), Cells(1, lc))
  If InStr(d, ",") Then
    h = d
    h = Replace(h, ",", ".")
    d.NumberFormat = "0.0"
    d = h
  End If
Next d
a = Range(Cells(1, 1), Cells(lr, lc))
n = Application.CountIf(Range(Cells(2, 2), Cells(lr - 1, lc)), ">0")
ReDim o(1 To n * 2, 1 To 3)
For i = 2 To UBound(a, 1)
  If a(i, 1) <> "" Then
    For c = 2 To lc
      If a(i, c) > 0 And a(i, c) <> "..." Then
        ii = ii + 1
        [B][COLOR=#ff0000]o(ii, 1) = a(i, 1)[/COLOR][/B]
        o(ii, 2) = a(1, c)
        o(ii, 3) = a(i, c)
      ElseIf a(i, 1) = "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = "..."
        o(ii, 3) = "..."
        GoTo Continue
      End If
    Next c
  End If
Next i
Continue:
Range("A1").Resize(UBound(oa, 1), UBound(oa, 2)) = oa
Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
lr = Cells(Rows.Count, lc + 3).End(xlUp).Row
Range(Cells(1, lc + 3), Cells(lr, lc + 3)).Font.Bold = True
Columns.AutoFit
Application.ScreenUpdating = True
End Sub

I checked a bit on the error code and found out that either it happens when
- a nonexistent collection member is referenced
- a nonexistent array element is referenced
- the number of elements is not defined

Then again, I have the feeling that we might be dealing rather with an excel 2007 compatibility issue here?

Best Regards

tabibito

 

[tabibito]

Hello hiker95,

I have no idea what happened on the excel 2007 PC in the meantime, but when I just retried executing the macro there, it worked just as perfectly as on my excel 2010 PC.
Just hope this problem is not going to come up again in the future.

Thank you anyways!
tabibito

 

[hiker95]

tabibito,

Strange, because, I am using Excel 2007, and, when I tested the macro based on your screenshot and description, it worked fine.

Can you give me your workbook for testing your actual raw data?


You can upload your workbook to Box Net,

sensitive data changed

mark the workbook for sharing
and provide us with a link to your workbook.

 

[tabibito]

Thank you very much, hiker95.

Please find the excel file via the following link:
https://app.box.com/s/1u5zy2cowkfkwthh11ie
(first time for me to use box.com - seems safe)

Kind Regards,
tabibito

 

[hiker95]

tabibito,

Thanks for the workbook. The new data structure and cell formatting is different than your original screenshot.

New sample raw data:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD
1	Start	60	60.5	61	61.5	62	62.5	63	63.5	64	64.5	65	65.5	66	66.5	67	67.5	68	69.5	80	80.5	81	81.5	82	82.5
2	1234-123		1				1				5				1
3	1233-122				1				1					1
4	1232-121																						2
5	1222-122		1		1																	1
6	1221-121			1				1			1	3	2	1										1
7	1212-111								1										1			1
8	1211-123																1
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sheet1

After the new macro:

Excel 2007
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD
1	Start	60	60.5	61	61.5	62	62.5	63	63.5	64	64.5	65	65.5	66	66.5	67	67.5	68	69.5	80	80.5	81	81.5	82	82.5			1234-123	60.5	1
2	1234-123		1				1				5				1													1234-123	62.5	1
3	1233-122				1				1					1														1234-123	64.5	5
4	1232-121																						2					1234-123	66.5	1
5	1222-122		1		1																	1						1233-122	61.5	1
6	1221-121			1				1			1	3	2	1										1				1233-122	63.5	1
7	1212-111								1										1			1						1233-122	66	1
8	1211-123																1											1232-121	81.5	2
9																												1222-122	60.5	1
10																												1222-122	61.5	1
11																												1222-122	81	1
12																												1221-121	61	1
13																												1221-121	63	1
14																												1221-121	64.5	1
15																												1221-121	65	3
16																												1221-121	65.5	2
17																												1221-121	66	1
18																												1221-121	82	1
19																												1212-111	63.5	1
20																												1212-111	69.5	1
21																												1212-111	81	1
22																												1211-123	67.5	1
23
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).

Option Explicit
Sub ReorgDataV2()
' hiker95, 02/06/2014, ME753744
Dim lr As Long, lc As Long, d As Range, h As String
Dim a As Variant, o As Variant, c As Long
Dim i As Long, ii As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
a = Range(Cells(1, 1), Cells(lr, lc))
n = Application.CountIf(Range(Cells(2, 2), Cells(lr - 1, lc)), ">0")
ReDim o(1 To n * 2, 1 To 3)
For i = 2 To UBound(a, 1)
  If a(i, 1) <> "" Then
    For c = 2 To lc
      If a(i, c) > "" And a(i, c) <> "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = a(1, c)
        o(ii, 3) = a(i, c)
      ElseIf a(i, 1) = "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = "..."
        o(ii, 3) = "..."
        GoTo Continue
      End If
    Next c
  End If
Next i
Continue:
Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
lr = Cells(Rows.Count, lc + 3).End(xlUp).Row
Range(Cells(1, lc + 3), Cells(lr, lc + 3)).Font.Bold = True
Columns.AutoFit
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 ReorgDataV2 macro.

 

[hiker95]

tabibito,

Thanks for the workbook. The new data structure and cell formatting is different than your original screenshots.

Sorry about the previous thread screenshots.

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 ReorgDataV2()
' hiker95, 02/06/2014, ME753744
Dim lr As Long, lc As Long, d As Range, h As String
Dim a As Variant, o As Variant, c As Long
Dim i As Long, ii As Long, n As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
a = Range(Cells(1, 1), Cells(lr, lc))
n = Application.CountIf(Range(Cells(2, 2), Cells(lr - 1, lc)), ">0")
ReDim o(1 To n * 2, 1 To 3)
For i = 2 To UBound(a, 1)
  If a(i, 1) <> "" Then
    For c = 2 To lc
      If a(i, c) > "" And a(i, c) <> "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = a(1, c)
        o(ii, 3) = a(i, c)
      ElseIf a(i, 1) = "..." Then
        ii = ii + 1
        o(ii, 1) = a(i, 1)
        o(ii, 2) = "..."
        o(ii, 3) = "..."
        GoTo Continue
      End If
    Next c
  End If
Next i
Continue:
Cells(1, lc + 3).Resize(UBound(o, 1), UBound(o, 2)) = o
lr = Cells(Rows.Count, lc + 3).End(xlUp).Row
Range(Cells(1, lc + 3), Cells(lr, lc + 3)).Font.Bold = True
Columns.AutoFit
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 ReorgDataV2 macro.