resorting table using array

Question

am trying to resort the data using Code consider the data shape like this :

Empid| 1/01/2019|2/01/2019 | 3/01/2019
-------------------------------------------
1    |    A     |    B     |    A
2    |    B     |    A     |    B
3    |    B     |    C     |    C
4    |    A     |    A     |    A

and the goal shape like this :

Empid | Date     | Shift
---------------------
 1    |1/01/2019 | A
 1    |2/01/2019 | B
 1    |3/01/2019 | A
 2    |1/01/2019 | B
 2    |2/01/2019 | A
 2    |3/01/2019 | B
 3    |1/01/2019 | B
 3    |2/01/2019 | C
 3    |3/01/2019 | C
 4    |1/01/2019 | A
 4    |2/01/2019 | A
 4    |3/01/2019 | A

i used this code and reached to this shape using the code :

Empid | Shift
---------------------
 1    |A
 1    |B
 1    |A
 2    |B
 2    |A
 2    |B
 3    |B
 3    |C
 3    |C
 4    |A
 4    |A
 4    |A

this is the vba code :

Sub TransposeData()
    Const FirstDataRow As Long = 2               ' presuming row 1 has headers
    Const YearColumn As String = "A"             ' change as applicable

    Dim Rng As Range
    Dim Arr As Variant, Pos As Variant
    Dim Rl As Long, Cl As Long
    Dim R As Long, C As Long
    Dim i As Long

    With ActiveSheet
        Cl = .UsedRange.Columns.Count - .UsedRange.Column + 1
        Rl = .Cells(.Rows.Count, Columns(YearColumn).Column).End(xlUp).Row
        Set Rng = Range(.Cells(FirstDataRow, YearColumn), .Cells(Rl, Cl))
    End With
    Arr = Rng.Value
    ReDim Pos(1 To (UBound(Arr) * UBound(Arr, 2)), 1 To 2)

    For R = 1 To UBound(Arr)
        For C = 2 To UBound(Arr, 2)
            i = i + 1
            Pos(i, 1) = Arr(R, 1)
            Pos(i, 2) = Arr(R, C)
        Next C
    Next R

    R = Rl + 5                                   ' write 5 rows below existing data
    Set Rng = ActiveSheet.Cells(R, YearColumn).Resize(i, 2)
    Rng.Value = Pos
End Sub

Answer 1

Array Approach

Option Explicit

Public Sub Rearrange()
  Dim t#: t = timer                                                 ' stop watch
  Dim ws As Worksheet                                               ' worksheet object
  Set ws = ThisWorkbook.Worksheets("Sheet3")                        ' << change to sheet name
  Const STARTCOL = "A"                                              ' << change to your needs
' [1] get last row in column A
  Dim r&, c&                                                        ' used rows/cols (assuming no blanks)
  r = ws.Range(STARTCOL & ws.Rows.count).End(xlUp).Row
  c = ws.Columns(STARTCOL).End(xlToRight).Column - ws.Columns(STARTCOL).Column
' [2] get values to 1-based 2-dim variant arrays
  Dim tmp, tgt
  tmp = ws.Range(ws.Cells(1, STARTCOL), ws.Cells(r, c + 1)).Value2
  ReDim tgt(1 To c * (UBound(tmp) - 1) + 1, 1 To c)                 ' resize target array
' [3] rearrange data in target array
  Dim i&, ii&, j&
  For i = 2 To UBound(tmp)
      For j = 2 To UBound(tmp, 2)                                   ' get row data
          ii = (i - 1) * c + j - c                                  ' calculate new row index
          tgt(ii, 1) = tmp(i, 1)                                    ' get ID
          tgt(ii, 2) = tmp(1, j)                                    ' get date
          tgt(ii, 3) = tmp(i, j)                                    ' get inditgtidual column data
      Next j
  Next i
  tgt(1, 1) = "EmpId": tgt(1, 2) = "Date": tgt(1, 3) = "Shift"      ' get captions

' [4] write target array back wherever you want it to               ' << redefine OFFSET
  ws.Range("A1").Offset(0, c + 2).Resize(UBound(tgt, 1), UBound(tgt, 2)) = tgt

  MsgBox "Time needed: " & Format(timer - t, "0.00") & " seconds."

End Sub

Note

You should format the target range with your preferred date formatting, e.g. "dd/mm/yyyy;@" .

Answer 2

Use Power Query (aka Get & Transform in Excel 2016+).

• Select the first column and UNpivot the other columns.

• Rename the resultant Date column (which will be named Attributes by the GUI), and the Shift column (which will be named Value by the GUI).

• If you want to do this in VBA, record a macro while running PQ

---

1. With a single cell selected in your table, select Get & Transform from Table/Range

2. Power Query will open. Ensure you have selected the first column. Then, from Transform, select the dropdown next to the Unpivot button. From that dropdown, select unpivot other columns.

3. After selecting that, you will see that you need to rename columns 2 and 3

4. After that, select one of the Close options from the File menu, and load the results to either the same sheet or another sheet.

Now you can rerun the query if your data changes.

And, as I wrote above, if you need to do this using VBA, just record a macro while you go through the steps.

I also suggest you search SO for unpivot and you'll get a lot of information.