Spending an hour+ a day copying and pasting

[FBLondon]

Hello,

I have a the below table with x's (only mine is 100x300).

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Adam[/TD]
[TD]John[/TD]
[TD]Fred[/TD]
[TD]Frank[/TD]
[/TR]
[TR]
[TD]Apples[/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]Pears[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]Bananas[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]Grapes[/TD]
[TD][/TD]
[TD]x[/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
[TR]
[TD]Oranges[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]x[/TD]
[/TR]
</tbody>[/TABLE]

I spend an hour+ each day copying and pasting into the below format by copying sheet and=IF(Sheet1!A2="x",$A1,""), remove blanks, shift up, transpose, then split out over rows.
[TABLE="class: grid, width: 2"]
<tbody>[TR]
[TD]Adam[/TD]
[TD]Apples[/TD]
[/TR]
[TR]
[TD]Adam[/TD]
[TD]Bananas[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Bananas[/TD]
[/TR]
[TR]
[TD]John[/TD]
[TD]Grapes[/TD]
[/TR]
[TR]
[TD]Fred[/TD]
[TD]Apples[/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD]Apples[/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD]Pears[/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD]Bananas[/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD]Grapes[/TD]
[/TR]
[TR]
[TD]Frank[/TD]
[TD]Oranges[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


I've searched and searched online for a solution but even have trouble even describing my problem to google.

Does anyone have a better way of doing this and save my life?

Thank you in advance

 

[Stiuart_W]

I'm sure this is something that can be done very easily in VBA

I have to go home now and will be back in the office Monday. If you get no response by then reply in the thread and I'll help you out

 

[offthelip]

This code will do it for you. You didn't specify where you wanted the result, so I have written it out onto Sheet2

With ActiveSheet


lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
inarr = Range(.Cells(1, 1), .Cells(lastrow, lastcol))


End With
With Worksheets("sheet2")
Range(.Cells(1, 1), .Cells(lastrow * lastcol, 2)) = ""
outarr = Range(.Cells(1, 1), .Cells(lastrow * lastcol, 2))
indi = 1
For i = 2 To lastcol
 For j = 2 To lastrow
   If inarr(j, i) = "x" Then
    outarr(indi, 1) = inarr(1, i)
    outarr(indi, 2) = inarr(j, 1)
    indi = indi + 1
   End If
 Next j
Next i


Range(.Cells(1, 1), .Cells(lastrow * lastcol, 2)) = outarr




End With
End Sub

 

[thisoldman]

Because the task is repeated, I'd favor the VBA solution. An alternative, unpivoting the data, can also be done using Get & Transform, also known as Power Query
https://support.office.com/en-us/ar...er-query-0f7bad4b-9ea1-49c1-9d95-f588221c7098

It took me forty-five seconds to unpivot the sample data in the original post.

 

[hiker95]

FBLondon,

Welcome to the MrExcel forum.

If I understand you correctly, then here is a macro solution for you to consider, that uses two arrays in memory.

With your raw data in worksheet Sheet1, the results will be written to worksheet Sheet2.

Sub ReorganizeData()
' hiker95, 01/26/2018, ME1040673
Application.ScreenUpdating = False
Dim w1 As Worksheet, w2 As Worksheet
Dim a As Variant, i As Long, c As Long, n As Long, lr As Long, lc As Long
Dim o As Variant, j As Long
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  n = Application.CountIf(.Range(.Cells(2, 2), .Cells(lr, lc)), "=x")
  a = .Cells(1, 1).CurrentRegion
  ReDim o(1 To n, 1 To 2)
End With
For c = 2 To UBound(a, 2)
  For i = 2 To UBound(a, 1)
    If a(i, c) = "x" Then
      j = j + 1: o(j, 1) = a(1, c): o(j, 2) = a(i, 1)
    End If
  Next i
Next c
With w2
  .Cells(1, 1).CurrentRegion.ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .UsedRange.Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub