Question

我有以下Excel工作表：

A          |B  |C  |D  |E  |F  |G  |
------------------------------------
01/12/2017 |1A |1B |1C |1D |1E |1G |
------------------------------------
02/12/2017 |2A |2B |2C |2D |2E |2G |
------------------------------------
01/12/2017 |1AA |1BB |1CC |1DD |1EE |1GG |
------------------------------------
03/12/2017 |3A |3B |3C |3D |3E |3G |
------------------------------------
04/12/2017 |4A |4B |4C |4D |4E |4G |
------------------------------------
04/12/2017 |4AA |4BB |4CC |4DD |4EE |4GG |

我想根据A栏转置它。我想这样做：

H           | I          | J         | K
-------------------------------------------------
01/12/2017  | 02/12/2017 | 03/12/2017| 04/12/2017
-------------------------------------------------
1A          |2A          |3A          |4A
-------------------------------------------------
1B          |2B          |3B          |4B
-------------------------------------------------
1C          |2C          |3C          |4C
-------------------------------------------------
1D          |2D          |3D          |4D
-------------------------------------------------
1E          |2E          |3E          |4E
-------------------------------------------------
1G          |2G          |3G          |4G
-------------------------------------------------
1AA         |            |            |4AA
-------------------------------------------------
1BB         |            |            |4BB
-------------------------------------------------
1CC         |            |            |4CC
-------------------------------------------------
1DD         |            |            |4DD
-------------------------------------------------
1EE         |            |            |
-------------------------------------------------
1GG         |            |            |
-------------------------------------------------

我之前尝试过，一无所获。我在VBA非常新。请帮我。谢谢。最诚挚的问候。

Answer 1

这不是一个直截了当的问题，因为必须按日期合并信息。

如果有多个相同的代码与特定日期关联，您也不会指出您想要发生什么。我选择忽略它，并且只列出唯一代码，但如果需要，您可以修改下面的代码以执行其他操作。

简化算法：

将数据读入VBA阵列（以提高处理速度）
创建具有以下属性的用户定义对象（类）：
- 相关日期
- 与该日期相关的所有代码的集合（字典）
将这些对象收集到另一个字典中，Key是相关日期
将信息重新排序为＆＃34;结果＆＃34;阵列
输出到工作表和格式。

阅读代码中的注释，因为它们非常重要

班级单元

'**Rename this Module:  cByDates**

Option Explicit

Private pDt As Date
Private pCode As String
Private pCodes As Dictionary

Public Property Get Dt() As Date
    Dt = pDt
End Property
Public Property Let Dt(Value As Date)
    pDt = Value
End Property

Public Property Get Code() As String
    Code = pCode
End Property
Public Property Let Code(Value As String)
    pCode = Value
End Property

Public Property Get Codes() As Dictionary
    Set Codes = pCodes
End Property
Public Function addCodesItem(Value)
    'bypass any duplicates
    If Not Codes.Exists(Value) Then _
    Codes.Add Value, Value
End Function

Private Sub Class_Initialize()
    Set pCodes = New Dictionary
        pCodes.CompareMode = TextCompare
End Sub

常规模块

'Set Reference to Microsoft Scripting Runtime

Option Explicit

Sub ConsolidateByDate()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim cBD As cByDates, dBD As Dictionary
    Dim I As Long, J As Long
    Dim lRC() As Long 'last row-col
    Dim V As Variant, W As Variant

'Setup worksheets and results range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

'read original data into VBA array for speed of processing
'if there is or will be other information on Sheet1, then you will need a
'   different routine to find the last row and column
With wsSrc
    lRC = LastRowCol(.Name)
    vSrc = .Range(.Cells(1, 1), .Cells(lRC(0), lRC(1)))
End With

'Collect and organize the data
Set dBD = New Dictionary
For I = 1 To UBound(vSrc, 1)
    For J = 2 To UBound(vSrc, 2)
        Set cBD = New cByDates
        With cBD
            .Dt = vSrc(I, 1)
            .Code = vSrc(I, J)
            .addCodesItem .Code

            If Not dBD.Exists(.Dt) Then
                dBD.Add Key:=.Dt, Item:=cBD
            Else
                dBD(.Dt).addCodesItem .Code
            End If
        End With
    Next J
Next I

'Create results array
'number of columns = number of dBD items
lRC(0) = 0
lRC(1) = dBD.Count

'number of rows = max codes count
For Each V In dBD.Keys
    lRC(0) = IIf(lRC(0) > dBD(V).Codes.Count, lRC(0), dBD(V).Codes.Count)
Next V

ReDim vRes(0 To lRC(0), 1 To lRC(1))

'Populate each column
J = 1
For Each V In dBD.Keys
    I = 0
    vRes(I, J) = V
    For Each W In dBD(V).Codes.Keys
        I = I + 1
        vRes(I, J) = W
    Next W
    J = J + 1
Next V

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With

End Sub

'------------------------------------------------------
Function LastRowCol(Worksht As String) As Long()
    Dim WS As Worksheet, R As Range
    Dim LastRow As Long, LastCol As Long
    Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
    Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByRows, _
                    searchdirection:=xlPrevious)

    If Not R Is Nothing Then
        LastRow = R.Row
        LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
                    LookIn:=xlValues, searchorder:=xlByColumns, _
                    searchdirection:=xlPrevious).Column
    Else
        LastRow = 1
        LastCol = 1
    End If
End With

L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function

原始数据

<强>结果

我尽量避免引用非SO信息，但我会在这里例外。有关课程的基本讨论，请参阅Chip Pearson的Introduction to Classes

使用VBA将列转置为行

1 个答案:

班级单元

常规模块