Vba 嵌套的 do while 循环创建矩阵

Question

I am trying to get the code to fill the matrix on the right with the sum values from the table on the left. The code is skipping the first iteration and only running one column.

Before

After

Sub CreatingMatrix()
    Cc = 15
    Cr = 6
    Pr = 6
    Sr = 6
    Mr = 6
    Mc = 15
    ii = 15
    i = 6

    Do While Cells(5, ii) <> ""
        ii = ii + 1
        T3C = Cells(5, Cc)
        T1C = Cells(Cr, 2)

        Do While Cells(i, 14) <> ""
            i = i + 1
            T3P = Cells(Pr, 14)
            T1P = Cells(Pr, 1)

            If (T3C = T1C) And (T3P = T1P) Then
                Rank = Cells(Sr, 5).Value
                Cells(Mr, Mc).Value = Rank
            End If
            Mr = Mr + 1
            Sr = Sr + 1
            Pr = Pr + 1
        Loop

        Mc = Mc + 1
        Cc = Cc + 1
        Cr = Cr + 1
    Loop

End Sub

Answer 1

3 loops, 3 counters but very inefficient.

Sub CreatingMatrix()

    Dim i As Long, x As Long, y As Long
    i = 6
    Do While Cells(i, "A") <> ""

        x = 15 ' O
        Do While Cells(5, x) <> ""
            y = 6
            Do While Cells(y, "N") <> ""
                If Cells(i, "A") = Cells(y, "N") And _
                    Cells(i, "B") = Cells(5, x) Then
                    Cells(y, x) = Cells(i, "E")
                    Exit Do
                End If
                y = y + 1
            Loop
            x = x + 1
        Loop
        i = i + 1
        
    Loop

End Sub

Answer 2

I used the pivot table suggestion with some extra code.

Sub PivotTableWithValues()
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
'Dim 3 As Long

'Insert a New Blank Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTable").Delete
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "PivotTable"
Application.DisplayAlerts = True
Set PSheet = Worksheets("PivotTable")
Set DSheet = Worksheets("Data")

'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
Set PRange = DSheet.Cells(5, 1).Resize(LastRow, 5)

'Define Pivot Cache
Set PCache = ActiveWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:=PRange). _
CreatePivotTable(TableDestination:=PSheet.Cells(2, 2), _
TableName:="ValuesTable")

'Insert Blank Pivot Table
Set PTable = PCache.CreatePivotTable _
(TableDestination:=PSheet.Cells(1, 1), TableName:="SalesPivotTable")

'Insert Row Fields
With ActiveSheet.PivotTables("ValuesTable").PivotFields("Class")
.Orientation = xlRowField
.Position = 1
End With

'Insert Column Fields
With ActiveSheet.PivotTables("ValuesTable").PivotFields("People")
.Orientation = xlColumnField
.Position = 1
End With

'Insert Data Field
With ActiveSheet.PivotTables("ValuesTable").PivotFields("Total")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Name = "Class Matrix"
End With

With ActiveSheet.PivotTables("ValuesTable")
.ColumnGrand = False
.RowGrand = False
End With

'Format Pivot Table
    ActiveSheet.PivotTables("ValuesTable").ShowDrillIndicators = False
    ActiveSheet.PivotTables("ValuesTable").DisplayFieldCaptions = False
ActiveSheet.PivotTables("ValuesTable").ShowTableStyleRowStripes = True
ActiveSheet.PivotTables("ValuesTable").TableStyle2 = "PivotStyleLight1"




'Sheets("PivotTable").Range("B3", Cells(LastRow, LastCol)).Copy
'Sheets("Data").Range("Q5").Paste
''Sheets("Data").PasteSpecial xlPasteValues


Worksheets("PivotTable").PivotTables("ValuesTable").TableRange2.Copy
Worksheets("Data").Range("Q5").PasteSpecial xlPasteValues

Application.DisplayAlerts = False
Sheets("PivotTable").Delete
Application.DisplayAlerts = True

End Sub

Then to get multiples

Sub MatrixSize()
Dim LastColumn As Long, LastRow As Long, LastRowG As Long
    Dim i As Long
    Dim rng As Range
    Dim FinClass As Range
Dim ValuesRange As Range
Dim NumClass As Integer

LastCol = Cells(5, Columns.Count).End(xlToLeft).Column
LastRow = Cells(Rows.Count, 17).End(xlUp).Row
LastRowG = Cells(Rows.Count, 7).End(xlUp).Row

i = 5
'from the first class Ta total to the last
Do Until Cells(i, "G") = ""
TestValue = Cells(i, "G")

'Find the number of times the value shows
Set rng = Range(Cells(7, "Q"), Cells(LastRow, "Q"))
NumClass = WorksheetFunction.CountIf(rng, TestValue)

'if numclass is not the correct value paste more
If NumClass <> Cells(i, "H") Then
'find the location of the Te
Set FinClass = Range(Cells(7, "Q"), Cells(LastRow, "Q")).Find(What:=TestValue) '.Address
'copy the row that contains the test values from it to the final column
  
'r = Range(FinClass, Cells(FinClass.Row, Cells(FinClass.Row, Columns.Count).End(xlToLeft).Column)).Copy

   iCol = Cells(FinClass.Row, Columns.Count).End(xlToLeft).Column - FinClass.Column + 1
    If iCol < 1 Then iCol = 1
    Set FinClass = FinClass.Resize(1, iCol)
FinClass.Copy Destination:=Cells(LastRow, "Q")

LastRow = LastRow + 1

Else
'test next value
i = i + 1
End If

Loop
End Sub