使用数组求助表 [英] resorting table using array

问题描述

我试图使用Code重新整理数据，请考虑这样的数据形状:

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

和这样的目标形状:

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

这是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

推荐答案

数组方法

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;@".

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

这篇关于使用数组求助表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！