Convert an Excel table to a list with VBA

I want to convert a table to a list
I am still struggling with VBA.
I have not been able to find a similar example.
Can anyone help ?

Thank you.

Wayne.

Input table - WorkSheet A
-------------------------
Week1 Week2 Week3 week4
Activity 1 1
Activity 2 2 3
Activity 3 2 5 4

Wanted output list on WorkSheet B

Desc Activity Qty
-----------------------------------
Week 1 Activity 1 1
Week 1 Activity 3 2
Week 2 Activity 2 2
Week 3 Activity 3 5
Week 4 Activity 2 3
Week 4 Activity 3 4

This is not a very sophisticated response, however, it will do the job.
Might be a good guide for a start.

Sub BuildTable()
Dim strWeek As String, strActivity As String, intRow As Integer, intCol
As Integer
Dim strQty As String, strRange As String

'Go to New Sheet and prepare table header
Sheets("Sheet2").Select
'Range("A1").Select 'raises error 1004 "not defined" ???
ActiveCell.Select
ActiveCell.Formula = "Desc"
'Range("B1").Select 'raises error 1004 "not defined" ???
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Activity"
'Range("C1").Select 'raises error 1004 "not defined" ???
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Qty"
ActiveCell.Offset(1, -2).Select
'Return to original data
Sheets("Sheet1").Select
'Cycle through original data
For intCol = 2 To 5 'For each column
Select Case intCol
Case 2: strRange = "B"
Case 3: strRange = "C"
Case 4: strRange = "D"
Case 5: strRange = "E"
End Select
Range(strRange & "2").Select
'Collect the column title
ActiveCell.Offset(-1, 0).Select
strWeek = ActiveCell.Text
ActiveCell.Offset(1, 0).Select

For intRow = 2 To 4 ' For each Row
Range(strRange & CStr(intRow)).Select
'Collect the row title
ActiveCell.Offset(0, -intCol + 1).Select
strActivity = ActiveCell.Text
ActiveCell.Offset(0, intCol - 1).Select
'if there is a quantity in the cell
If ActiveCell.Text <> "" Then
strQty = ActiveCell.Text
Sheets("Sheet2").Select
'Range("A2").Select
While ActiveCell.Text <> ""
ActiveCell.Offset(1, 0).Select
Wend
ActiveCell.Formula = strWeek
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = strActivity
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = strQty
ActiveCell.Offset(1, -2).Select
Sheets("Sheet1").Select
End If

Next intRow

Next intCol

End Sub


Good luck from Tasmania

"[email protected]" wrote:

> I want to convert a table to a list
> I am still struggling with VBA.
> I have not been able to find a similar example.
> Can anyone help ?
>
> Thank you.
>
> Wayne.
>
> Input table - WorkSheet A
> -------------------------
> Week1 Week2 Week3 week4
> Activity 1 1
> Activity 2 2 3
> Activity 3 2 5 4
>
> Wanted output list on WorkSheet B
>
> Desc Activity Qty
> -----------------------------------
> Week 1 Activity 1 1
> Week 1 Activity 3 2
> Week 2 Activity 2 2
> Week 3 Activity 3 5
> Week 4 Activity 2 3
> Week 4 Activity 3 4
>
>

Thanks again.

What is the expected development of such line ? Error trapping ?

'Range("A1").Select 'raises error 1004 "not defined" ???

.... and if so can you give me some continuations ?

This exercise was definetely what the Doctor ordered.

One more...

Option Explicit
Sub testme()
Dim NewWks As Worksheet
Dim CurWks As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

NewWks.Range("a1").Resize(1, 3).Value _
= Array("Desc", "Activity", "Qty")

oRow = 1
With CurWks
For iRow = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
For iCol = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Trim(.Cells(iRow, iCol).Value) = "" Then
'do nothing
Else
oRow = oRow + 1
NewWks.Cells(oRow, "A").Value = .Cells(1, iCol).Value
NewWks.Cells(oRow, "B").Value = .Cells(iRow, "A").Value
NewWks.Cells(oRow, "C").Value = .Cells(iRow, iCol).Value
End If
Next iCol
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit
End Sub


[email protected] wrote:
>
> I want to convert a table to a list
> I am still struggling with VBA.
> I have not been able to find a similar example.
> Can anyone help ?
>
> Thank you.
>
> Wayne.
>
> Input table - WorkSheet A
> -------------------------
> Week1 Week2 Week3 week4
> Activity 1 1
> Activity 2 2 3
> Activity 3 2 5 4
>
> Wanted output list on WorkSheet B
>
> Desc Activity Qty
> -----------------------------------
> Week 1 Activity 1 1
> Week 1 Activity 3 2
> Week 2 Activity 2 2
> Week 3 Activity 3 5
> Week 4 Activity 2 3
> Week 4 Activity 3 4

--

Dave Peterson

And another...

Public Sub ChangeTable()
Dim I As Long
Dim J As Long
Dim NewSheet As Worksheet
Dim iRow As Long
Dim vaNewTable() As Variant
Dim vaOldTable As Variant
Dim iLastRow As Long
Dim iLastColumn As Integer
iLastRow = Cells(Range("A:A").Rows.Count, 2).End(xlUp).Row
iLastColumn = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column
vaOldTable = Range(Cells(2, 2), Cells(iLastRow, iLastColumn)).Value
Dim vaWeek As Variant
Dim vaActivity As Variant
vaWeek = Range(Cells(1, 2), Cells(1, iLastColumn))
vaActivity = Range(Cells(2, 1), Cells(iLastRow, 1))
For I = 1 To UBound(vaWeek, 2)
For J = 1 To UBound(vaActivity, 1)
If vaOldTable(J, I) <> "" Then
iRow = iRow + 1
ReDim Preserve vaNewTable(3, iRow)
vaNewTable(3, iRow) = vaOldTable(J, I)
vaNewTable(2, iRow) = vaActivity(J, 1)
vaNewTable(1, iRow) = vaWeek(1, I)
End If
Next J
Next I
Set NewSheet = Worksheets.Add
NewSheet.Name = "Sheet" & ActiveWorkbook.Worksheets.Count
Range("A1").Value = "Desc"
Range("B1").Value = "Activity"
Range("C1").Value = "Qty"
Range("A2").Resize(UBound(vaNewTable, 2), UBound(vaNewTable, 1)) = _
WorksheetFunction.Transpose(vaNewTable)
End Sub

Good luck from mainland Australia:-)

Ken Johnson

Oops, left out Option Base One

Option Base 1
Option Explicit

Public Sub ChangeTable()
Dim I As Long
Dim J As Long
Dim NewSheet As Worksheet
Dim iRow As Long
Dim vaNewTable() As Variant
Dim vaOldTable As Variant
Dim iLastRow As Long
Dim iLastColumn As Integer
iLastRow = Cells(Range("A:A").Rows.Count, 2).End(xlUp).Row
iLastColumn = Cells(1, Range("1:1").Columns.Count).End(xlToLeft).Column
vaOldTable = Range(Cells(2, 2), Cells(iLastRow, iLastColumn)).Value
Dim vaWeek As Variant
Dim vaActivity As Variant
vaWeek = Range(Cells(1, 2), Cells(1, iLastColumn))
vaActivity = Range(Cells(2, 1), Cells(iLastRow, 1))
For I = 1 To UBound(vaWeek, 2)
For J = 1 To UBound(vaActivity, 1)
If vaOldTable(J, I) <> "" Then
iRow = iRow + 1
ReDim Preserve vaNewTable(3, iRow)
vaNewTable(3, iRow) = vaOldTable(J, I)
vaNewTable(2, iRow) = vaActivity(J, 1)
vaNewTable(1, iRow) = vaWeek(1, I)
End If
Next J
Next I
Set NewSheet = Worksheets.Add
NewSheet.Name = "Sheet" & ActiveWorkbook.Worksheets.Count
Range("A1").Value = "Desc"
Range("B1").Value = "Activity"
Range("C1").Value = "Qty"
Range("A2").Resize(UBound(vaNewTable, 2), UBound(vaNewTable, 1)) = _
WorksheetFunction.Transpose(vaNewTable)
End Sub

Typical, Aye.

Ken Johnson

Wooww !!! I am baffled by the quality of the response
My grasping of VBA logic & syntax went from 5 to 8.
Thank you all.

Wayne

Now, I am pushing it one step further. Can you help me again ?

Namely :
1. Calling Closed Workbook "A" from Active Workbook "B"
2. A second row of column headers
3. A new column "Price" and a calculated column "Cost" being the
result of Price x Qty


Input table - WorkBook A
-------------------------
Price Week1 Week1 Week2 Week2
AM PM AM PM
Activity 1 3 1
Activity 2 7 2 3
Activity 3 5 2 5 4


Wanted output list on WorkBook B


Desc Period Activity Qty Price Cost
---------------------------------------------------
Week 1 AM Activity 1 1 3 3
Week 1 AM Activity 3 2 5 10
Week 1 PM Activity 2 2 7 14
Week 2 AM Activity 3 5 5 25
Week 2 PM Activity 2 3 7 21
Week 2 PM Activity 3 4 5 20

I wasn't sure if you wanted a value in the Cost (I call that extended price--not
cost) or just the value, so you'll have to delete

Open workbook A first.

Then assign the CurWks variable to that workbook.

Set CurWks = Worksheets("Sheet1")
becomes:
Set CurWks = workbooks("workbookA.xls").Worksheets("Sheet1")
(change the workbook name and sheet name accordingly.

And this line
Set NewWks = Worksheets.Add
can become:
Set NewWks = thisworkbook.Worksheets.Add
or
Set NewWks = activeworkbook.Worksheets.Add
depending on what workbook should get the new sheet--the workbook with the code
or the workbook that you're looking at in excel.


Option Explicit
Sub testme2()

Dim NewWks As Worksheet
Dim CurWks As Worksheet
Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

NewWks.Range("a1").Resize(1, 6).Value _
= Array("Desc", "Period", "Activity", "Qty", "Price", "Ext Price")

oRow = 1
With CurWks
For iRow = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
For iCol = 3 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Trim(.Cells(iRow, iCol).Value) = "" Then
'do nothing
Else
oRow = oRow + 1
'desc (always row 1)
NewWks.Cells(oRow, "A").Value = .Cells(1, iCol).Value
'Period (always row 2)
NewWks.Cells(oRow, "B").Value = .Cells(2, iCol).Value
'Activity (always column A)
NewWks.Cells(oRow, "C").Value = .Cells(iRow, "A").Value
'Qty (in the data)
NewWks.Cells(oRow, "D").Value = .Cells(iRow, iCol).Value
'Price (always column B)
NewWks.Cells(oRow, "E").Value = .Cells(iRow, "B").Value
'Extended Price (a formula or a value??)
'if formula
NewWks.Cells(oRow, "F").FormulaR1C1 _
= "=rc[-2]*rc[-1]"
'if value
'NewWks.Cells(oRow, "F").Value _
' = .Cells(iRow, iCol).Value * .Cells(iRow, "B").Value
End If
Next iCol
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit
End Sub


===============
And if you really want the code to open the workbook A, you can do this:

Option Explicit
Sub testme2()

Dim WkbkA As Workbook
Dim WkbkAName As String
Dim WkbkAPath As String

Dim CurWksName As String
Dim CurWks As Worksheet

Dim TestStr As String
Dim WkbkAWasOpen As Boolean

Dim NewWks As Worksheet

Dim iRow As Long
Dim iCol As Long
Dim oRow As Long

'Change the next few lines to match what you need.
WkbkAPath = "C:\my documents\excel"
If Right(WkbkAPath, 1) <> "\" Then
WkbkAPath = WkbkAPath & "\"
End If
WkbkAName = "book2.xls"
CurWksName = "sheet12"

TestStr = ""
On Error Resume Next
TestStr = Dir(WkbkAPath & WkbkAName)
On Error GoTo 0
If TestStr = "" Then
MsgBox "That other workbook doesn't exist"
Exit Sub
End If

WkbkAWasOpen = True

Set WkbkA = Nothing
On Error Resume Next
Set WkbkA = Workbooks(WkbkAName)
On Error GoTo 0

If WkbkA Is Nothing Then
'it's not open, so open it
Set WkbkA = Workbooks.Open(Filename:=WkbkAPath & WkbkAName, _
ReadOnly:=True)
WkbkAWasOpen = False
End If

Set CurWks = Nothing
On Error Resume Next
Set CurWks = WkbkA.Worksheets(CurWksName)
On Error GoTo 0

If CurWks Is Nothing Then
MsgBox "That worksheet doesn't exist!"
Else
Set NewWks = ThisWorkbook.Worksheets.Add

NewWks.Range("a1").Resize(1, 6).Value _
= Array("Desc", "Period", "Activity", "Qty", "Price", "Ext Price")

oRow = 1
With CurWks
For iRow = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
For iCol = 3 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If Trim(.Cells(iRow, iCol).Value) = "" Then
'do nothing
Else
oRow = oRow + 1
'desc (always row 1)
NewWks.Cells(oRow, "A").Value = .Cells(1, iCol).Value
'Period (always row 2)
NewWks.Cells(oRow, "B").Value = .Cells(2, iCol).Value
'Activity (always column A)
NewWks.Cells(oRow, "C").Value = .Cells(iRow, "A").Value
'Qty (in the data)
NewWks.Cells(oRow, "D").Value _
= .Cells(iRow, iCol).Value
'Price (always column B)
NewWks.Cells(oRow, "E").Value = .Cells(iRow, "B").Value
'Extended Price (a formula or a value??)
'if formula
NewWks.Cells(oRow, "F").FormulaR1C1 _
= "=rc[-2]*rc[-1]"
'if value
'NewWks.Cells(oRow, "F").Value _
' = .Cells(iRow, iCol).Value * .Cells(iRow, "B").Value
End If
Next iCol
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit
End If

'clean up
If WkbkAWasOpen Then
'do nothing
Else
WkbkA.Close savechanges:=False
End If
End Sub



[email protected] wrote:
>
> Wooww !!! I am baffled by the quality of the response
> My grasping of VBA logic & syntax went from 5 to 8.
> Thank you all.
>
> Wayne
>
> Now, I am pushing it one step further. Can you help me again ?
>
> Namely :
> 1. Calling Closed Workbook "A" from Active Workbook "B"
> 2. A second row of column headers
> 3. A new column "Price" and a calculated column "Cost" being the
> result of Price x Qty
>
> Input table - WorkBook A
> -------------------------
> Price Week1 Week1 Week2 Week2
> AM PM AM PM
> Activity 1 3 1
> Activity 2 7 2 3
> Activity 3 5 2 5 4
>
> Wanted output list on WorkBook B
>
> Desc Period Activity Qty Price Cost
> ---------------------------------------------------
> Week 1 AM Activity 1 1 3 3
> Week 1 AM Activity 3 2 5 10
> Week 1 PM Activity 2 2 7 14
> Week 2 AM Activity 3 5 5 25
> Week 2 PM Activity 2 3 7 21
> Week 2 PM Activity 3 4 5 20

--

Dave Peterson