create 1 master list from a combination of rows and columns

[Jason]

Hi there

I have a spreadsheet that contains approx 584 rows and 163 columns. Column A
= Account, Column B = Description, Columns C+ = Department.

Something like this

ACCT DESCRIPTION 1101 2140 3125 6179
12345 Example 1 X
22588 Example 1 X X X
33244 Example 1 X X
78544 Example 1 X X X
78545 Example 1 X X

Is it possible to use VBA to achieve the following:

ACCT DESCRIPTION DEPT
12345 Example 1 1101
22588 Example 1 1101
22588 Example 1 2140
22588 Example 1 3125
33244 Example 1 2140
33244 Example 1 3125
78544 Example 1 2140
78544 Example 1 3125
78544 Example 1 6179
78545 Example 1 3125
78545 Example 1 6179

 

[Luke M]

Something like this:

Sub TransposeColumns()
'Start row of destination
i = 2
'Range of Departments
For Each cell In Range("C2:F10")

If cell.Value = "X" Then
xRow = cell.Row
xColumn = cell.Column

'Change first part of formula to destination
'columns as desired
Cells(i, "G").Value = Cells(xRow, "A")
Cells(i, "H").Value = Cells(xRow, "B")
Cells(i, "I").Value = Cells(1, xColumn)
i = i + 1
End If
Next

End Sub

 

[Don Guillett]

Assumes you have cols g:i available. After you may delete cols a:f or
uncomment the last line to make it automatic

Sub makenewlist()
r = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To 6
If UCase(Cells(i, j)) = "X" Then
Cells(r, "g") = Cells(i, "a")
Cells(r, "h") = Cells(i, "b")
Cells(r, "i") = Cells(1, j)
r = r + 1
End If
Next j
Next i
'columns("a:f").delete
End Sub

 

[Otto Moehrbach]

Jason
Try this. I assumed that you had a sheet named Utility and that the
resulting table will be placed in that sheet. HTH Otto
Sub ReArrange()
Dim rColA As Range, i As Range, TheRng As Range
Dim j As Range, Dest As Range
Set rColA = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Sheets("Utility")
Set Dest = .Range("A2")
For Each i In rColA
If Cells(i.Row, Columns.Count).End(xlToLeft).Column > 2 Then
Set TheRng = Range(Cells(i.Row, 3), Cells(i.Row,
Columns.Count).End(xlToLeft))
For Each j In TheRng
If Not IsEmpty(j.Value) Then
Dest = i.Value
Dest.Offset(, 1) = i.Offset(, 1).Value
Dest.Offset(, 2) = Cells(1, j.Column).Value
Set Dest = Dest.Offset(1)
End If
Next j
End If
Next i
End With
End Sub