请各位老师帮忙用VBA实现成绩的拆分和合并，谢谢！

xinxin8899

请各位老师帮忙用VBA实现成绩的拆分和合并，谢谢！

一把小刀闯天下

Option Explicit

Sub 拆分()
  Dim arr, i, j, k, m, n, t
  Sheets("拆分").Activate
  arr = [a2].CurrentRegion
  ReDim brr(1 To UBound(arr, 1) * 10, 1 To 6)
  For i = 2 To UBound(arr, 1)
    t = Split(arr(i, 5)): n = 0
    For j = 0 To UBound(t)
      m = m + 1: n = n + 1
      brr(m, 1) = m: brr(m, 2) = arr(i, 2) & "-" & n
      brr(m, 3) = arr(i, 3): brr(m, 4) = arr(i, 4)
      For k = 1 To Len(t(j))
        If IsNumeric(Mid(t(j), k, 1)) Then
          brr(m, 6) = Mid(t(j), k)
          brr(m, 5) = Replace(t(j), brr(m, 6), vbNullString)
          Exit For
        End If
  Next k, j, i
  [a14].Resize(m, UBound(brr, 2)) = brr
End Sub

Sub 合并()
  Dim arr, i, a, b, m, p, sum
  Sheets("合并").Activate
  arr = [a2].CurrentRegion.Offset(1)
  For i = 1 To UBound(arr, 1) - 1
    sum = sum + arr(i, 6)
    a = a & "、" & arr(i, 2): b = b & "、" & arr(i, 5)
    If arr(i, 3) <> arr(i + 1, 3) Then
      m = m + 1
      arr(m, 1) = m: arr(m, 2) = Mid(a, 2): arr(m, 3) = arr(i, 3)
      arr(m, 4) = arr(p + 1, 4): arr(m, 5) = Mid(b, 2): arr(m, 6) = sum
      p = i: sum = 0: a = vbNullString: b = a
    End If
  Next
  [a25].Resize(m, UBound(arr, 2)) = arr
End Sub

xinxin8899

一把小刀闯天下 发表于 2019-5-19 08:19
Option Explicit

Sub 拆分()

谢谢一把小刀闯天下老师！完全满足我的请求，太感谢了！

xiangbaoan

…………………………

xinxin8899

一把小刀闯天下 发表于 2019-5-19 08:19
Option Explicit

Sub 拆分()

一把小刀闯天下老师如果科目前都有一个数字序号（如图，比原来增加了红色字体部分），拆分时需要怎么修改语句呢？谢谢了！

xinxin8899

xiangbaoan 发表于 2019-5-19 09:34
…………………………

也谢谢xiangbaoan老师！

一把小刀闯天下

xinxin8899 发表于 2019-5-19 12:36
一把小刀闯天下老师如果科目前都有一个数字序号（如图，比原来增加了红色字体部分），拆分时需要怎么修改 ...

Option Explicit

Sub 拆分()
  Dim arr, i, j, k, m, n, t
  Sheets("拆分").Activate
  arr = [a2].CurrentRegion
  ReDim brr(1 To UBound(arr, 1) * 10, 1 To 6)
  For i = 2 To UBound(arr, 1)
    t = Split(arr(i, 5)): n = 0
    For j = 0 To UBound(t)
      m = m + 1: n = n + 1
      brr(m, 1) = m: brr(m, 2) = arr(i, 2) & "-" & n
      brr(m, 3) = arr(i, 3): brr(m, 4) = arr(i, 4)
      For k = Len(t(j)) To 1 Step -1
        If Not IsNumeric(Mid(t(j), k, 1)) Then
          brr(m, 6) = Mid(t(j), k + 1)
          brr(m, 5) = Left(t(j), k)
          Exit For
        End If
  Next k, j, i
  [a14].Resize(m, UBound(brr, 2)) = brr
End Sub

xinxin8899

一把小刀闯天下 发表于 2019-5-19 12:58
Option Explicit

Sub 拆分()

谢谢老师的回复，不过我又发现有个别学生的分数有小数，如图所示，还得麻烦您给修改一下，如果不好处理，可以把所有学生的成绩变为一位小数（比如政治68.0），辛苦您了

xinxin8899

有部分成绩是带一位小数的，麻烦您有时间再给修改一下

xinxin8899

一把小刀闯天下 发表于 2019-5-19 12:58
Option Explicit

Sub 拆分()

老师，有部分成绩是带一位小数的，麻烦您有时间再给修改一下