枢轴遥控车
- 将所有四个过程复制到标准模块，例如
Module1。
- 仔细调整
pivotRCV 的Define constants. 部分中的值。
- 只运行第一个过程
pivotRCV，其他的都被它调用了。
守则
Option Explicit
Sub pivotRCV() ' RCV: Row Labels, Column Labels, and Values
' Define constants.
' Define Source constants.
Const srcName As String = "Price Entry Book"
Const srcFirst As String = "A2"
Const rlCol As Long = 1
Const clCol As Long = 2
Const vCol As Long = 4
Const rlSort As Boolean = False
Const clSort As Boolean = False
' Define Target constants.
Const tgtName As String = "Matrix"
Const tgtFirst As String = "A2"
' Define workbooks.
Dim src As Workbook
Set src = ThisWorkbook
Dim tgt As Workbook
Set tgt = ThisWorkbook
' Define Source Range.
' Define Source Worksheet.
Dim ws As Worksheet
Set ws = src.Worksheets(srcName)
' Define Source Range.
Dim rng As Range
Set rng = defineEndRange(ws.Range(srcFirst))
' Write values from Source Range to arrays.
' Write values from Source Range to 1D Unique Row Labels Array.
Dim rLabels As Variant
rLabels = getUniqueColumn1D(rng.Columns(rlCol).Resize(rng.Rows.Count - 1) _
.Offset(1))
If rlSort Then
sort1D rLabels
End If
' Write values from Source Range to 1D Unique Column Labels Array.
Dim cLabels As Variant
cLabels = getUniqueColumn1D(rng.Columns(clCol).Resize(rng.Rows.Count - 1) _
.Offset(1))
If clSort Then
sort1D cLabels
End If
' Write values from Source Range to 2D Source Array.
Dim Source As Variant
Source = rng.Value
' Prepare to write values from Source Array to Target Array.
' Define Target Array.
Dim Target As Variant
ReDim Target(1 To UBound(rLabels) - LBound(rLabels) + 2, _
1 To UBound(cLabels) - LBound(cLabels) + 2)
' Define counters.
Dim n As Long
Dim i As Long
i = 1
' Write values from Source Arrays to Target Array.
' Write first row/column label.
Target(1, 1) = Source(1, 1)
' Write row labels.
For n = LBound(rLabels) To UBound(rLabels)
i = i + 1
Target(i, 1) = rLabels(n)
Next n
' Write column labels.
Dim j As Long
j = 1
For n = LBound(cLabels) To UBound(cLabels)
j = j + 1
Target(1, j) = cLabels(n)
Next n
' Write values.
For n = 2 To UBound(Source, 1)
i = Application.Match(Source(n, rlCol), rLabels, 0) + 1
j = Application.Match(Source(n, clCol), cLabels, 0) + 1
Target(i, j) = Source(n, vCol)
Next n
' Write values from Target Array to Target Range.
' Define Target Worksheet.
Set ws = tgt.Worksheets(tgtName)
' Define Target First Row Range.
With ws.Range(tgtFirst).Resize(, UBound(Target, 2))
' Clear contents from Target First Row Range to the bottom-most row.
.Resize(ws.Rows.Count - .Row + 1).ClearContents
' Define Target Range.
Set rng = .Resize(UBound(Target, 1))
End With
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
' Defines the range from a specified first cell to the last cell
' of its Current Region.
Function defineEndRange(FirstCellRange As Range) _
As Range
' Define Current Region ('rng').
Dim rng As Range
Set rng = FirstCellRange.CurrentRegion
' Define End Range.
Set defineEndRange = FirstCellRange _
.Resize(rng.Rows.Count + rng.Row - FirstCellRange.Row, _
rng.Columns.Count + rng.Column - FirstCellRange.Column)
End Function
' Returns the unique values from a column range.
Function getUniqueColumn1D(ColumnRange As Range, _
Optional ByVal Sorted As Boolean = False) _
As Variant
Dim Data As Variant
Data = ColumnRange.Columns(1).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data, 1)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
.Item(Key) = Empty
End If
Next i
getUniqueColumn1D = .Keys
End With
End Function
' Sorts a 1D array only if it contains the same data type.
Sub sort1D(ByRef OneD As Variant, _
Optional ByVal Descending As Boolean = False)
With CreateObject("System.Collections.ArrayList")
Dim i As Long
For i = LBound(OneD) To UBound(OneD)
.Add OneD(i)
Next i
.Sort
If Descending Then
.Reverse
End If
OneD = .ToArray
End With
End Sub