用空单元格转置
- 将完整代码复制到标准模块中（例如
Module1）。
- 仔细调整常量部分中的值。
- 只运行
Sub。 Function 由 Sub 调用。
守则
Sub transposeMonths()
' Define constants.
Const srcNameOrIndex As Variant = "Sheet1"
Const FirstRow As Long = 2
Const SourceColumn As Long = 1
Const ValueColumn As Long = 2
Const tgtNameOrIndex As Variant = "Sheet1"
Const tgtFirstCell As String = "D1"
Const Separator As String = "-"
Dim CurrYear As Long: CurrYear = 2019
Dim Months As Variant
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
Dim wb As Workbook: Set wb = ThisWorkbook
' Add Separator and Current Year to Months Array.
Dim ubM As Long: ubM = UBound(Months)
Dim j As Long
For j = 0 To ubM
Months(j) = Months(j) & Separator & CurrYear
Next j
Months = Application.Transpose(Application.Transpose(Months))
ubM = ubM + 1
' Read from Source Ranges to Source Arrays.
Dim src As Worksheet: Set src = wb.Worksheets(srcNameOrIndex)
Dim Source(1) As Variant
Source(0) = getColumnValues(src, SourceColumn, FirstRow)
Dim ubS As Long: ubS = UBound(Source(0))
Source(1) = src.Cells(FirstRow, ValueColumn).Resize(ubS)
Set src = Nothing
' Count unique items.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim CurrMonth As String, i As Long
For i = 1 To ubS
CurrMonth = Source(0)(i, 1)
If CurrMonth <> "" Then
dict(CurrMonth) = dict(CurrMonth) + 1
End If
Next i
' Write from Source Arrays to Target Array.
Dim Target As Variant
ReDim Target(1 To Application.Max(dict.Items) + 1, 1 To ubM)
For j = 1 To ubM
Target(1, j) = Months(j)
Next j
For i = ubS To 1 Step -1
CurrMonth = Source(0)(i, 1)
If CurrMonth <> "" Then
Target(dict(CurrMonth) + 1, Application.Match(CurrMonth, Months, 0)) _
= Source(1)(i, 1)
dict(CurrMonth) = dict(CurrMonth) - 1
End If
Next i
' Write from Target Array to Target Range.
Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtNameOrIndex)
tgt.Range(tgtFirstCell).Resize(UBound(Target), UBound(Target, 2)) = Target
' Inform user.
MsgBox "Data copied.", vbInformation, "Success"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values of a non-empty one-column range starting '
' from a specified row, to a 2D one-based one-column array. '
' Returns: A 2D one-based one-column array. '
' Remarks: If the column is empty or its last non-empty row is above '
' the specified row or if an error occurs the function will '
' return an empty variant. Therefore the function's result '
' can be tested with "IsEmpty". '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnValues(Sheet As Worksheet, _
Optional ByVal AnyColumn As Variant = 1, _
Optional ByVal FirstRow As Long = 1) _
As Variant
On Error GoTo exitProcedure
Dim rng As Range
Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Function
If rng.Row < FirstRow Then Exit Function
Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)
Dim Result As Variant
If rng.Rows.Count = 1 Then
ReDim Result(1 To 1, 1 To 1): Result(1, 1) = rng.Value
Else
Result = rng.Value
End If
getColumnValues = Result
exitProcedure:
End Function