列表在VBA代码中转换矩阵表

Posted 2023-03-22

【中文标题】列表在VBA代码中转换矩阵表

【英文标题】：Column Table convert Matrix Table in VBA code

【发布时间】：2021-02-16 07:28:54

【问题描述】：

当前我使用公式（索引和匹配）来创建我希望使用 VBA 编码的矩阵，这将更快地与公式进行比较。提前致谢 enter image description here

 Sub columntomatrix
 Dim mS As Worksheet
 Dim eS As Worksheet

 Set mS = ThisWorkbook.Sheets("Matrix")
 Set eS = ThisWorkbook.Sheets("Price Entry Book")

 Dim Matrix() As String
 Dim entryPrice() As String
 Dim Product As Range
 Dim PriceBook As Range
 Set Product = Range("Product")
 Set PriceBook = Range("PriceBookName")

 With mS.Range("B2")
    .Formula = "=IFERROR(INDEX(ListPrice,
     MATCH(" & .Offset(0,-1).Address(False, True) & "&" & 
    .Offset(-1, 0).Address(True, False) & ",ProductKey,0)),"" N/A  "")"

Product.Copy
'offset(0,-1) = selected cells move to left 1 column'
.Offset(0, -1).PasteSpecial

PriceBook.Copy
.offset(-1,0) = selected cells move to up 1 row'
.Offset(-1, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True

With Range(.Offset(0, 0), .Offset(Product.Rows.Count - 2, PriceBook.Rows.Count - 2))
    .FillDown
    .FillRight
End with
End with
End Sub

【问题讨论】：

您的问题是什么？为什么你认为 VBA 会比内置公式更快？

所以你的目标是创建第一个（矩阵表）？最简单的方法是将其放入数据透视表中，第二个最简单的方法是记录一个将其放入数据透视表的宏，然后按照您的需要对其进行格式化。

@Marc 当我运行数千行和列时，如果我使用公式，运行代码时会延迟几分钟

【参考方案1】：

枢轴遥控车

将所有四个过程复制到标准模块，例如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