求大神帮忙用表1和表2生成表3中数据，感激不禁

chinasun0

1-N班表1和表2均有出现，则表3中显示表1中总分*表2中各科占比                               
Z班和X班表1中有，表2中没有，表3中A列显示表1的Z班和X班，B列显示“总成绩”字符，C列显示表1的总成绩                               
                               
右侧代码中仅保留了表1和表2都有的部分，但是表1中没有的部分就删除了，现在想保留下来，求大神帮忙看看怎么调整。多谢       

wxxydl

Sub test()
    Dim ar, br
    Dim i&, j&
    ar = Sheet1.Range("A1").CurrentRegion
    br = Sheet2.Range("A1").CurrentRegion
    ReDim cr(1 To 1000, 1 To 3)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(br)
        Dic(br(i, 1)) = ""
    Next
    For i = 2 To UBound(ar)
        If Dic.Exists(ar(i, 1)) Then
            For j = 2 To UBound(br, 2)
                k = k + 1
                cr(k, 1) = ar(i, 1)
                cr(k, 2) = Left(br(1, j), Len(br(1, j)) - 2)
                cr(k, 3) = ar(i, 2) * Val(br(i, j))
            Next
        Else
            k = k + 1
            cr(k, 1) = ar(i, 1)
            cr(k, 2) = "总成绩"
            cr(k, 3) = ar(i, 2)
        End If
    Next
    With Sheet3
        .Cells.Clear
        .Range("A1").Resize(, UBound(cr, 2)) = Split("班级 科目 成绩")
        .Range("A2").Resize(k, UBound(cr, 2)) = cr
    End With
    Set Dic = Nothing
End Sub

罗达

留印记，空了练手

chinasun0

wxxydl 发表于 2023-2-21 23:25
Sub test()
    Dim ar, br
    Dim i&, j&

感谢您的帮助，多谢