flip a sheet format

[sm1]

Hi,

I am looking for a solution where I could change the table in a different
format. Any office product solution, Excel or Access or any other tool could
be used where the process can be automated (macro, SQL query, etc)

I have this table:
T1 App1, App2, App3
T2 App4, App5
T3 App6, App7, App8

I want to create this table of the previous table:
App1 T1
App2 T1
App3 T1
App4 T2
App5 T2
App6 T3
App7 T3
App8 T3


Thank you for any help

 

[Roger Govier]

Hi

The following code should do what you want.

Sub ChangeLayout()

Dim i As Long, j As Long, k As Long, lr As Long, lc As Long
Dim wss As Worksheet, wsd As Worksheet

Set wss = ThisWorkbook.Sheets("Sheet1") ' Source
Set wsd = ThisWorkbook.Sheets("Sheet2") 'Destination
lr = wss.Cells(Rows.Count, "A").End(xlUp).Row ' last row
' find maximum number of columns
lc = wss.Cells.Find("*", Cells(1, 1), , , xlByColumns,
xlPrevious).Column
k = 1
For i = 1 To lr
For j = 2 To lc
If wss.Cells(i, j) <> "" Then
wsd.Cells(k, 1) = wss.Cells(i, j)
wsd.Cells(k, 2) = wss.Cells(i, 1)
k = k + 1
End If
Next j
Next i
End Sub

 

[Dave Mills]

This does it. Has a few sanity tests too.


Option Explicit
Sub ReorganiseDate()
'Steps down the selection copying the first column in
'each row to the destination row and all following non
'blank cells in the row to the second column of the destination.
'The destination is set the be below the selection.

Dim rngData As Range
Dim lngStartRow As Long
Dim lngEndRow As Long
Dim lngStartCol As Long
Dim lngDestRow As Long
Dim lngDestCol As Long
Dim lngRow As Long
Dim lngCol As Long
Dim lngOffset As Long
Dim StrTestA As String
Dim StrTestB As String


Set rngData = ActiveWindow.RangeSelection
lngStartRow = rngData.Row
lngStartCol = rngData.Column
lngEndRow = rngData.End(xlDown).Row

If Cells(lngStartRow, lngStartCol) = "" Then
MsgBox "Start cell is empty, did you forget to select the rows?"
Exit Sub
End If

If lngEndRow > 30000 Then
MsgBox "End row to big, did you forget to select the rows?"
Exit Sub
End If


lngDestRow = lngEndRow + 2
lngDestCol = lngStartCol

'step down each row
For lngRow = lngStartRow To lngEndRow
If Cells(lngRow, lngStartCol).Value <> "" Then
'Copy the Row to the destination cells
lngOffset = 1
Do While Cells(lngRow, lngStartCol + lngOffset).Value <> ""

StrTestA = CStr(Cells(lngDestRow, lngStartCol).Value)
StrTestB = CStr(Cells(lngDestRow, lngStartCol + 1).Value)
If StrTestA > "" Or StrTestB > "" Then
MsgBox "Destination cell is occupied at row " & lngDestRow & ",
aborting!"
Exit Sub
Else
Cells(lngDestRow, lngStartCol).Value = Cells(lngRow,
lngStartCol).Value
Cells(lngDestRow, lngStartCol + 1).Value = Cells(lngRow, lngStartCol +
lngOffset).Value
lngOffset = lngOffset + 1
lngDestRow = lngDestRow + 1
End If
Loop
End If
Next lngRow

End Sub