我不是数据透视表方面的专家，我以愚蠢的方式做到了这一点 - 但可以。假设：
1) 源数据始终在“Sheet1”上，带有这 3 个列标题
2）“Sheet2”将用于存储排序数据
Sub SO_19105503()
Const NameCol As Long = 1
Const TaskCol As Long = 2
Const DateCol As Long = 3
Dim oShSrc As Worksheet, oShTgt As Worksheet, R As Long, C As Long
Dim aNames As Variant, aDates As Variant
Dim lNames As Long, lDates As Long
Dim oRng As Range, oArea As Range
Set oShSrc = ThisWorkbook.Worksheets("Sheet1") ' Source worksheet with original data
oShSrc.Copy Before:=oShSrc
Set oShSrc = ThisWorkbook.Worksheets("Sheet1 (2)") ' Copy of Source worksheet
Set oShTgt = ThisWorkbook.Worksheets("Sheet2") ' Target worksheet to store sorted data
oShSrc.AutoFilterMode = False
' Get unique names (sorted) in column A
aNames = Array()
lNames = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, NameCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, NameCol)) And oShSrc.Cells(R, NameCol).Value <> oShSrc.Cells(R - 1, NameCol).Value Then
ReDim Preserve aNames(lNames)
aNames(lNames) = oShSrc.Cells(R, NameCol).Value
lNames = lNames + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, NameCol))
' Get unique dates (sorted) in column C
aDates = Array()
lDates = 0
R = 1
oShSrc.UsedRange.Sort Key1:=oShSrc.Cells(R, DateCol), Header:=xlYes
Do
R = R + 1
If Not IsEmpty(oShSrc.Cells(R, DateCol)) And oShSrc.Cells(R, DateCol).Value <> oShSrc.Cells(R - 1, DateCol).Value Then
ReDim Preserve aDates(lDates)
aDates(lDates) = oShSrc.Cells(R, DateCol).Value
lDates = lDates + 1
End If
Loop Until IsEmpty(oShSrc.Cells(R, DateCol))
' Prepare and put data to Target sheet
oShTgt.Range("A1").Value = oShSrc.Range("A1").Value ' Name
' Insert Dates (start from column B on Row 1)
For C = 0 To lDates - 1
oShTgt.Cells(1, C + 2).Value = aDates(C)
Next
' Insert Names (start from Row 2 on Column A)
For R = 0 To lNames - 1
oShTgt.Cells(R + 2, 1).Value = aNames(R)
Next
' Reprocess the source data with Autofilter
For R = 0 To lNames - 1
oShSrc.AutoFilterMode = False ' Remove AutoFilter before apply
' Apply AutoFilter with Criteria of R'th entry in array aNames
oShSrc.UsedRange.AutoFilter Field:=1, Criteria1:="=" & aNames(R)
' Go through Ranges in each Area
For Each oArea In oShSrc.Cells.SpecialCells(xlCellTypeVisible).Areas
For Each oRng In oArea.Rows
' Stop checking if row is more than used
If oRng.Row > oShSrc.UsedRange.Rows.count Then
Exit For
End If
' Check only if the row is below the header
If oRng.Row > 1 Then
For C = 0 To lDates - 1
' Find the matching date and put the "Task" value
If oShSrc.Cells(oRng.Row, DateCol).Value = aDates(C) Then
oShTgt.Cells(R + 2, C + 2).Value = oShSrc.Cells(oRng.Row, TaskCol).Value
Exit For
End If
Next C
End If
Next oRng
Next oArea
Next R
Application.DisplayAlerts = False
oShSrc.Delete ' Delete the temporary data source sheet
Application.DisplayAlerts = True
Set oShSrc = Nothing
Set oShTgt = Nothing
End Sub
屏幕截图 - 源数据/结果：
