Creating a 1D list from a 2D list and looping it through the entire workbook

[akatz821]

Hey everyone,
sorry about the format of the post, its my first time posting here
I've been using the following code (which is from another forum) that takes a 2D array of the following sample format:
[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]Date 1[/TD]
[TD]date2[/TD]
[/TR]
[TR]
[TD]object 1[/TD]
[TD]Value a[/TD]
[TD]Value b
[/TD]
[/TR]
[TR]
[TD]object 2[/TD]
[TD]Value c[/TD]
[TD]Value d[/TD]
[/TR]
</tbody>[/TABLE]


and puts it into this format:[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]object 1[/TD]
[TD]date 1[/TD]
[TD]value a[/TD]
[/TR]
[TR]
[TD]object 1[/TD]
[TD]date 2[/TD]
[TD]value b[/TD]
[/TR]
[TR]
[TD]object 2[/TD]
[TD]date 1[/TD]
[TD]value c[/TD]
[/TR]
[TR]
[TD]object 2[/TD]
[TD]date 2[/TD]
[TD]value d[/TD]
[/TR]
</tbody>[/TABLE]

for files obviously much larger than the sample. the code is as follows:

Sub WorksheetLoop()
' Dim Current As Worksheet
' For Each Current In Worksheets

Dim SummaryTable As Range, OutputRange As Range
Dim OutRow As Long
Dim r As Long, c As Long


On Error Resume Next
Set SummaryTable = ActiveCell.CurrentRegion
If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
MsgBox "Select a cell within the summary table.", vbCritical
Exit Sub
End If
SummaryTable.Select
Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)


OutRow = 2
Application.ScreenUpdating = True
OutputRange.Range("A1:C3") = Array("Object", "Date", "Amount")
For r = 2 To SummaryTable.Rows.Count
For c = 2 To SummaryTable.Columns.Count
OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
OutRow = OutRow + 1
Next c
Next r
' MsgBox Current.Name
' Next


End Sub

I want to try and update it and have the new code include the following:

Insert a first column (making it a 4 column table) where each cell is filled with the name of the sheet
keep the date formatting, instead of turning it into a number
instead of having to select a cell within your table to start, have the program automatically take A1 and capture the table from here
instead of having to select/input where you want the new table to be, have it automatically place itself starting on cell A25 (for example)
lastly, and perhaps least importantly but most interestingly, I would like to have the macro run through all the sheets within the workbook. as you can see, i have an idea within the code(commented out because it doesn't yet do what i want) that goes to each worksheet, but places the table from the first worksheet there instead.

Thanks in advance!!

 

[akatz821]

realized the code formatted intself like a paragraph, uploading it here hopefully in a better way!

Sub WorksheetLoop()
'    Dim Current As Worksheet
'   For Each Current In Worksheets
   
        Dim SummaryTable As Range, OutputRange As Range
        Dim OutRow As Long
        Dim r As Long, c As Long


        On Error Resume Next
        Set SummaryTable = ActiveCell.CurrentRegion
        If SummaryTable.Count = 1 Or SummaryTable.Rows.Count < 3 Then
            MsgBox "Select a cell within the summary table.", vbCritical
            Exit Sub
        End If
        SummaryTable.Select
        Set OutputRange = Application.InputBox(prompt:="Select a cell for the 3-column output", Type:=8)


        OutRow = 2
        Application.ScreenUpdating = True
        OutputRange.Range("A1:C3") = Array("Object", "Date", "Amount")
        For r = 2 To SummaryTable.Rows.Count
            For c = 2 To SummaryTable.Columns.Count
                OutputRange.Cells(OutRow, 1) = SummaryTable.Cells(r, 1)
                OutputRange.Cells(OutRow, 2) = SummaryTable.Cells(1, c)
                OutputRange.Cells(OutRow, 3) = SummaryTable.Cells(r, c)
                OutputRange.Cells(OutRow, 3).NumberFormat = SummaryTable.Cells(r, c).NumberFormat
                OutRow = OutRow + 1
            Next c
        Next r
 '      MsgBox Current.Name
 '   Next
    
    
End Sub