使用阵列诉诸表

Question

我尝试使用代码考虑这样的数据形状诉诸数据：

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

和目标形状是这样的：

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

我用这个码并达到使用的代码本的形状：

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

这是VBA代码：

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

使用Power Query（又名Get & Transform在Excel 2016+）。

• 选择第一列和unpivot的其他列。
• 重命名所得日期栏（这将是由GUI被命名Attributes），并且移位柱（这将是由GUI被命名Value）。
• 如果你想这样做在VBA，录制宏在运行PQ

---

1. 在你的表格中选择一个单元格，从Get & Transform选择Table/Range

2. 电源查询将打开。确保你所选择的第一列。然后，变换，选择旁边Unpivot按钮的下拉。从下拉列表中，选择unpivot other columns。

3. 选择在此之后，你会发现你需要重命名列2和3

4. 之后，选择的从文件菜单中的关闭选项之一，并将结果加载到同一片或另一个片材。

现在你可以，如果你的数据的变化重新运行查询。

而且，正如我上面写的，如果你需要做到这一点使用VBA，刚刚录制宏，而你经过的步骤。

我也建议你搜索，以便为逆转置，你会得到很多的信息。

Answer 2

阵手法

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

注意

你应该用你喜欢的日期格式，例如格式化目标范围"dd/mm/yyyy;@"。