遍历矩阵 table 并存储在列 table 的新工作表中

Question

矩阵Table

列Table

如何将矩阵（不是多列）转换为VBA代码中的第table列？

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 code.In 相同的函数列 matrix.now 我使用公式方式，我希望转换为 VBA 编码

Answer 1

这是 Powerquery 解决方案，以防您发现它比评论中的 VBA 解决方案更容易。（SO 将指令检测为代码，即使它们不是）

Make sure every column has a title>highlight your data>insert>add table
Data>from table/range
Select product Name>right click>unpivot other columns
Filter out N/A
Rename columns/arrange order
Add column>duplicate product name and price book
Merge new columns/rename
save&load

Before/After

代码（可以复制到视图>高级编辑器中。请务必将源保留为您的来源）

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Product Name", type text}, {"China Price Book", type text}, {"US Price Book", Int64.Type}, {"UK Price Book", Int64.Type}, {"SG Price Book", Int64.Type}, {"JP Price Book", Int64.Type}, {"Standard Price book", Int64.Type}}),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Product Name"}, "Attribute", "Value"),
    #"Filtered Rows" = Table.SelectRows(#"Unpivoted Other Columns", each ([Value] <> "N/A")),
    #"Renamed Columns" = Table.RenameColumns(#"Filtered Rows",{{"Attribute", "Price Book"}, {"Value", "List Price"}}),
    #"Reordered Columns" = Table.ReorderColumns(#"Renamed Columns",{"Product Name", "List Price", "Price Book"}),
    #"Duplicated Column" = Table.DuplicateColumn(#"Reordered Columns", "Product Name", "Product Name - Copy"),
    #"Duplicated Column1" = Table.DuplicateColumn(#"Duplicated Column", "Price Book", "Price Book - Copy"),
    #"Merged Columns" = Table.CombineColumns(#"Duplicated Column1",{"Product Name - Copy", "Price Book - Copy"},Combiner.CombineTextByDelimiter("", QuoteStyle.None),"Merged"),
    #"Renamed Columns1" = Table.RenameColumns(#"Merged Columns",{{"Merged", "Product Key"}})
in
    #"Renamed Columns1"

Answer 2

逆透视：按列，Headers

之前的值

在运行代码之前，调整常量部分中的值。

代码

Option Explicit

Sub unpivotData()
    
    ' Define constants.
    
    Const srcName As String = "Matrix"
    Const srcFirst As String = "B1" ' Including headers.
    Const lrCol As Variant = "B"
    Const cCount As Long = 7
    Const repCount As Long = 1
    
    Const tgtName As String = "Price Entry Book"
    Const tgtFirst As String = "A2" ' Excluding headers.
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Source Range ('rng').
    
    Dim ws As Worksheet
    Set ws = wb.Worksheets(srcName)
    Dim lRow As Long
    lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
    Dim rCount As Long
    rCount = lRow - ws.Range(srcFirst).Row + 1
    Dim rng As Range
    Set rng = ws.Range(srcFirst).Resize(rCount, cCount)
    
    ' Write values from Source Range to Source Array ('Source').
    
    Dim Source As Variant
    Source = rng.Value
    
    ' Write values from Source Array to Target Array ('Target').
    
    Dim Target As Variant
    ReDim Target(1 To rCount * (cCount - repCount), 1 To repCount + 2)
    
    Dim cVal As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    
    For j = 1 + repCount To cCount
        For i = 2 To rCount
            cVal = Source(i, j)
            If Not IsError(cVal) Then
                If Not IsEmpty(cVal) And cVal <> "N/A" Then
                    k = k + 1
                    For l = 1 To repCount
                        Target(k, l) = Source(i, l)
                    Next l
                    Target(k, l) = cVal
                    Target(k, l + 1) = Source(1, j)
                End If
            End If
        Next i
    Next j
    If k = 0 Then Exit Sub
    
    ' Write values from Target Array to Target Range.
    
    Set ws = wb.Worksheets(tgtName)
    With ws.Range(tgtFirst).Resize(, repCount + 2)
        ' Clear contents below header row.
        .Resize(ws.Rows.Count - ws.Range(tgtFirst).Row + 1).ClearContents
        ' Write values.
        .Resize(k).Value = Target
    End With

    ' Inform user.
    MsgBox "Data transferred.", vbInformation, "Success"

End Sub

遍历矩阵 table 并存储在列 table 的新工作表中

Loop through Matrix table and store in new sheets of column table

excel

vba

powerquery

unpivot

逆透视：按列，Headers