求助：如何根据多条件填写表格

于箱长

守望麦田的蜗牛 发表于 2022-12-31 16:56
是我想要的结果，因为我自身不懂的原因，一增加行列数，又出现了不能运行的情况

于箱长

守望麦田的蜗牛 发表于 2022-12-31 16:56
是我想要的结果，因为我自身不懂的原因，一增加行列数，又出现了不能运行的情况

红框里为先给定的条件（不清除）

gwjkkkkk

Sub TEST6()
    Dim arr, brr, vData, i&, j&, R&, dic As Object, vKey, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    brr = [{"年级","班级","语文","数学","英语","班主任"}]
    arr = [A1].CurrentRegion.Resize(, 5)
    ReDim vData(1 To UBound(arr), 1 To 6)
    For i = 1 To UBound(brr)
       vData(1, i) = brr(i)
       dic(brr(i)) = i
    Next
    R = 1
   
    For i = 3 To UBound(arr)
        brr = Split(arr(i, 5), "、")
        For j = 0 To UBound(brr)
            vKey = arr(i, 3) & Val(brr(j)) & "班"
            If Not dic.exists(vKey) Then
               R = R + 1
               dic(vKey) = R
               vData(R, 1) = arr(i, 3)
               vData(R, 2) = Val(brr(j)) & "班"
            End If
            iPosRow = dic(vKey)
            If arr(i, 4) <> "" Then
               vData(iPosRow, dic(arr(i, 4))) = arr(i, 1)
            End If
            If arr(i, 2) = "班主任" Then
               vData(iPosRow, dic(arr(i, 2))) = arr(i, 1)
            End If
        Next j
    Next i
   
    Columns("L:Q").ClearContents
    [L1].Resize(R, 6) = vData
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请楼主参考附件。。。

守望麦田的蜗牛

gwjkkkkk 发表于 2022-12-31 18:05
请楼主参考附件。。。

谢谢“gwjkkkkk”老师的帮助，同时请问一下，如果我把信息换成初中的，如：brr = [{"年级","班级","语文","数学","英语","物理","化学","历史","生物","班主任"}]
    arr = [A1].CurrentRegion.Resize(, 5)
    ReDim vData(1 To UBound(arr), 1 To 6)
    For i = 1 To UBound(brr)
       vData(1, i) = brr(i)怎样增加列数？谢谢！

守望麦田的蜗牛

gwjkkkkk 发表于 2022-12-31 18:05
请楼主参考附件。。。

Sub TEST6()
    Dim arr, brr, vData, i&, j&, R&, dic As Object, vKey, iPosRow&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    brr = [{"年级","班级","语文","数学","物理","历史","化学","英语","班主任"}]
    arr = [A1].CurrentRegion.Resize(, 5)
    ReDim vData(1 To UBound(arr), 1 To 9)
    For i = 1 To UBound(brr)
       vData(1, i) = brr(i)
       dic(brr(i)) = i
    Next
    R = 1
   
    For i = 3 To UBound(arr)
        brr = Split(arr(i, 5), "、")
        For j = 0 To UBound(brr)
            vKey = arr(i, 3) & Val(brr(j)) & "班"
            If Not dic.exists(vKey) Then
               R = R + 1
               dic(vKey) = R
               vData(R, 1) = arr(i, 3)
               vData(R, 2) = Val(brr(j)) & "班"
            End If
            iPosRow = dic(vKey)
            If arr(i, 4) <> "" Then
               vData(iPosRow, dic(arr(i, 4))) = arr(i, 1)
            End If
            If arr(i, 2) = "班主任" Then
               vData(iPosRow, dic(arr(i, 2))) = arr(i, 1)
            End If
        Next j
    Next i
   
    Columns("L:Q").ClearContents
    [L1].Resize(R, 9) = vData
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub
老师，我这样改了，能统计与计算了，但又没有框线了，谢谢！！

守望麦田的蜗牛

gwjkkkkk 发表于 2022-12-31 18:05
请楼主参考附件。。。

同时，如果我在前面增加了单位，如何增加代码。非常感谢老师的鼎力支持，谢谢老师！！

守望麦田的蜗牛