循环遍历矩阵表并存储在新的列表中[重复]

Question

矩阵表

列表

如何在VBA代码中将矩阵（不是多列）转换为列表？

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 代码。在与矩阵相同的函数列中。现在我使用公式方式，我希望转换为 VBA 编码

Answer 1

这是 Powerquery 解决方案，以防您发现它比 cmets 中的 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

之前/之后

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

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

反透视：按列、标题前的值

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

守则

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