Iterate Through, Save, and Format Cells in VBA

Question

I have an automated report that generates a table of values that need to be iterated through and saved to a different format.

Here is the table:

John Smith      5/26/2018   12345   IT Pro     John Gault   Permitting  Sarasota
Winston Smith   5/30/2018   54321   Henchman   Bob          Licensing   Oceania

The format that I'm looking to get that information to is the following:

Name:   John Smith
Date Starting:  5/26/2018
Employee ID#:   12345
Title:  IT PRO
Supervisor: John Gault
Bus Ctr:    Permitting
Location:   Oceania

Name:   Winston Smith
Date Starting:  5/30/2018
Employee ID#:   54321
Title:  Henchman
Supervisor: Bob
Bus Ctr:    Licensing
Location:   Oceania

The amount of employees on the report will change on a given day, so I believe a For Each is in order, something to the effect of:

For Each Cell In ActiveSheet.UsedRange.Cells

I'm just uncertain what to put into the For loop.

Answer 1

You can do some interesting stuff with Excel's Get & Transform functions. First - here are the manual steps:

1. Add a row as header with column names
2. Select the table and press Ctrl+T to create a table
3. On the Data Tab, click From Table
4. In the new editor that pops up, select all columns
5. On the Transform tab, click Unpivot
6. Save and exit

This isn't as straight forward as a macro, but Get & Transform is very powerful in cases like this.

Answer 2

Could you try this code. I suppose that your data is in a sheet "data".

Sub test()
Application.DisplayAlerts = False

Dim sh_final As String
sh_final = "final"

Dim sh_data As String
sh_data = "data" 'change if different

Dim sh_template As String
sh_template = "template"


'create sheet template
Dim ws As Worksheet
For Each ws In Worksheets
    If ws.Name = sh_template Then
    ws.Delete
    End If
Next ws

 With ThisWorkbook
     .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sh_template
 End With
With ThisWorkbook.Sheets(sh_template)
     .Range("A1").Value = "Name :"
     .Range("A2").Value = "Date Starting:"
     .Range("A3").Value = "Employee ID#:"
     .Range("A4").Value = "Title :"
     .Range("A5").Value = "Supervisor:"
     .Range("A6").Value = "Bus Ctr:"
     .Range("A7").Value = "Location:"
 End With

'create sheet final
For Each ws In Worksheets
    If ws.Name = sh_final Then
    ws.Delete
    End If
Next ws
 With ThisWorkbook
     .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = sh_final
 End With

'Copy data from sheet data
    For i = 1 To ThisWorkbook.Sheets(sh_data).Range("A" & ThisWorkbook.Sheets(sh_data).Rows.Count).End(xlUp).Row

    LastRow = ThisWorkbook.Sheets(sh_final).Range("A" & ThisWorkbook.Sheets(sh_final).Rows.Count).End(xlUp).Row + 1

    'Copy the template
    With ThisWorkbook.Sheets(sh_template)
    .Activate
    .Range("A1:A7").Copy
    End With

    With ThisWorkbook.Sheets(sh_final)
    .Activate
    .Range("A" & LastRow).Select
    End With
    ActiveSheet.Paste

    'copy the data
    With ThisWorkbook.Sheets(sh_data)
        .Activate
        .Range("A" & i & ":G" & i).Copy
    End With

    With ThisWorkbook.Sheets(sh_final)
        .Activate
        .Range("B" & LastRow).Select
    End With
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Next i


Application.DisplayAlerts = True

End Sub

Answer 3

Approach via transposed datafield array

Get data via a transposed datafield array (rows and columns changed), rearrange the array structure once after a reverse loop (within the same array) and write the array back to a target sheet:

Code example

This code example assumes you have a header line in row 1:1 in your data sheet:

Option Explicit                                      ' declaration head of your code module

Sub Iterate()
  Dim i As Long, j As Long, n As Long
  Dim nCol As Long, sCol As String
  Dim v                                               ' short for Dim v As Variant
  Dim ws As Worksheet, ws2 As Worksheet

  Set ws = ThisWorkbook.Worksheets("MyData")          ' << change to data sheet name
  Set ws2 = ThisWorkbook.Worksheets("MyTarget")       ' << change to target sheet name
' [1] get last row in column A containing data
   n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' [2] count header columns A:G (=7) and add one column to receive free line
   nCol = 7 + 1          ' nCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
' [3] get column letter after multiplication of rows with nCol
   sCol = Split(Cells(1, (n - 1) * nCol).Address, "$")(1)
' [4] get values to transposed one based 2dim array
   v = Application.Transpose(ws.Range("A1:" & sCol & n).Value)
' [5] rearrange data by reverse loop
  For i = n To 2 Step -1
     For j = 1 To nCol
       ' assign header (col 1) and data (col 2) to array items
         v((i - 2) * nCol + j, 1) = v(j, 1)  ' header
         v((i - 2) * nCol + j, 2) = v(j, i)  ' data
     Next j
  Next i
' [6] write back to target sheet
  ws2.Range("A:B") = ""                         ' clear columns A:B in target sheet
  ReDim Preserve v(1 To UBound(v), 2)           ' redim array to 2 columns
  ws2.Range("A1").Resize(UBound(v), 2) = v      ' write back
End Sub

Notes

Usually the (not yet transposed) datafield array would contain n data rows and nCol columns. As this example tries to reuse the original array, the data range gets greater to include all items multiplied by 8 (i.e. 7 columns plus an empty one).

• As the data range will be transposed, columns change to rows.
• As the total lines have to contain the product rows (n-1, i.e. without header line) * 8, it's necessary to define a greater column range to receive a greater array for later rearrangement - see section [3] with definition of a column letter.
• The array item v((i - 2) * nCol + j,2) rearranges the data items only in column 2 to write them back later to target sheet column B. The new row index ((i- 2) * nCol + j has to calculate i-2 considering the header line (-1) as well as a start from zero (-1), multiplied by nCol plus column j.