选修课成绩 T 分计算

wtqzhjb

wengjl 发表于 2024-10-28 16:19
在文档的第二张表上，由你设置的

帅哥，你的方案很好，非常感谢。麻烦帮忙看看，用赋分表直接查找返回分数，如何实现呢？具体见上面附件

wtqzhjb

wengjl 发表于 2024-10-28 16:19
在文档的第二张表上，由你设置的

还是用vba来做，如何实现呢？

wengjl

Sub 赋分表转换()
    ' https://club.excelhome.net/thread-1700680-2-1.html
    '
    ' 2024-10-29
    Sheet2.Activate
    x2 = 2
    Do While Not (IsEmpty(Sheet2.Cells(x2, 1).Value))
      For i = 1 To 30 Step 5
        For j = 20 To 37
          If Sheet1.Cells(i, j).Value = Sheet2.Cells(x2, 1).Value Then
            Sheet2.Cells(x2, 2).Value = Sheet1.Cells(i + 1, j).Value
            Sheet2.Cells(x2, 3).Value = Sheet1.Cells(i + 2, j).Value
            Sheet2.Cells(x2, 4).Value = Sheet1.Cells(i + 3, j).Value
            Sheet2.Cells(x2, 5).Value = Sheet1.Cells(i + 4, j).Value
          End If
        Next j
      Next i
      x2 = x2 + 1
    Loop
End Sub

Sub 提取T分()
    ' 2024-10-29
    Sheet1.Activate
    x1 = 2
    Do While Not (IsEmpty(Sheet1.Cells(x1, 3).Value))
      For y = 7 To 10
        ysf = Sheet1.Cells(x1, y).Value
        For x2 = 2 To 101
          If Sheet2.Cells(x2, 1).Value = ysf Then
            Sheet1.Cells(x1, y + 4).Value = Sheet2.Cells(x2, y - 5).Value
          End If
        Next x2
      Next y
      x1 = x1 + 1
    Loop
End Sub

wtqzhjb

谢谢帅哥，辛苦您了哈，我试一下，应该没问题

wengjl

wtqzhjb 发表于 2024-10-29 08:54
谢谢帅哥，辛苦您了哈，我试一下，应该没问题

肯定是能通过的，因为我试过可行。

不过附件下载是没用的，因为公司电脑有加密

你需要手工插入一张表，按图打上表头，办好原始分。将代码复制粘贴进去，执行就可以了

wtqzhjb

wengjl 发表于 2024-10-29 08:35
Sub 赋分表转换()
    ' https://club.excelhome.net/thread-1700680-2-1.html
    '

转化一下确实好用一点，完全没问题，谢谢帅哥

cunfu2010

使用字典可以省略掉转化的过程

wengjl

cunfu2010 发表于 2024-10-29 18:49
使用字典可以省略掉转化的过程

阿哈，你怎么把代码删了呢！！！

cunfu2010

wengjl 发表于 2024-10-30 09:41
阿哈，你怎么把代码删了呢！！！

有个小瑕疵，修改一下

cunfu2010

wengjl 发表于 2024-10-30 09:41
阿哈，你怎么把代码删了呢！！！

查验一下行不行：
Sub test()
  Set d = CreateObject("scripting.dictionary")
  With Worksheets("赋分")
    .Range("K2:N523").ClearContents
    arr = .Range("R1:AK30")
    For j = 1 To UBound(arr) Step 5
      For k = LBound(arr) + 2 To UBound(arr, 2)
        For i = 1 To 4
        If Not d.exists(arr(j + i, 2) & arr(j, k)) Then
          d(arr(j + i, 2) & arr(j, k)) = arr(j + i, k)
        End If
        Next
      Next
    Next
    brr = .Range("G1:J" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    For i = 2 To UBound(brr)
      For j = 1 To UBound(brr, 2)
        If d.exists(Mid(brr(1, j), 1, 2) & brr(i, j)) Then
          .Cells(i, 10 + j) = d(Mid(brr(1, j), 1, 2) & brr(i, j))
        End If
      Next
    Next
  End With
End Sub