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

一把小刀闯天下

xinxin8899 发表于 2019-5-19 17:59
老师，有部分成绩是带一位小数的，麻烦您有时间再给修改一下

7楼
If Not IsNumeric(Mid(t(j), k, 1)) Then 改成：

--------
If Not IsNumeric(Mid(t(j), k, 1)) And Mid(t(j), k, 1) <> "." Then

xinxin8899

一把小刀闯天下老师您好，真是十分感激，麻烦您了

xinxin8899

一把小刀闯天下 发表于 2019-5-19 20:46
7楼
If Not IsNumeric(Mid(t(j), k, 1)) Then 改成：

老师您好，在合并的vba中，我想再自动生成一列平均值（如图所示），语句该怎么修改呢？请有空时给以指教，谢谢！

飞天篮球猪

拆分用正则试了一下，供参考

1. Sub split_column()
   
2. Dim shtdata As Worksheet, arr, rlt(1 To 500, 1 To 6)
   
3. 
   
4. Set shtdata = Sheets("拆分")
   
5. arr = shtdata.Range("a2").CurrentRegion
   
6. 
   
7. For i = 2 To UBound(arr)
   
8.        With CreateObject("VBSCRIPT.REGEXP")
   
9.                  .Pattern = "(\d\D+)(\d+\.?\d?)"
   
10.                  .Global = True
    
11.                  n = 0
    
12.                  For Each m In .Execute(arr(i, 5))
    
13.                          j = j + 1: n = n + 1
    
14.                         rlt(j, 1) = j: rlt(j, 2) = arr(i, 2) & "-" & n
    
15.                         rlt(j, 3) = arr(i, 3): rlt(j, 4) = arr(i, 4)
    
16.                         rlt(j, 5) = m.submatches(0): rlt(j, 6) = m.submatches(1)
    
17.                 Next m
    
18.       End With
    
19. Next i
    
20. 
    
21. shtdata.Range("a30").Resize(1, 6) = Array("序号", "编号", "姓名", "班级", "学科", "成绩")
    
22. shtdata.Range("a31").Resize(j, 6) = rlt
    
23. 
    
24. End Sub
    

复制代码

飞天篮球猪

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

合并的写法挺好的

一把小刀闯天下

xinxin8899 发表于 2019-5-20 20:52
老师您好，在合并的vba中，我想再自动生成一列平均值（如图所示），语句该怎么修改呢？请有空时给以指教 ...

Option Explicit

Sub 合并()
  Dim arr, i, a, b, m, p, sum
  Sheets("合并").Activate
  arr = [a2].CurrentRegion.Offset(1).Resize(, 7)
  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: arr(m, 7) = Round(sum / (i - p), 1)
      p = i: sum = 0: a = vbNullString: b = a
    End If
  Next
  [a25].Resize(m, UBound(arr, 2)) = arr
End Sub

飞天篮球猪

也用字典法合并同类行，供参考

1. Sub combine_rows()
   
2. 
   
3. Dim dic, rawdata, sz, jg
   
4. 
   
5. Set dic = CreateObject("Scripting.Dictionary")
   
6. Set rawdata = Sheets("合并").Range("a2").CurrentRegion
   
7. 
   
8. cols = rawdata.Columns.Count
   
9. ReDim jg(1 To rawdata.Rows.Count, 1 To cols + 1)
   
10. sz = rawdata
    
11. 
    
12. For i = 2 To UBound(sz)
    
13.        If dic.exists(sz(i, 3)) Then
    
14.                 r = dic(sz(i, 3)): n = n + 1     '如果字典存在姓名，则返回该姓名所在的行号，并累计1次重复次数
    
15.                 jg(r, 2) = jg(r, 2) & "," & sz(i, 2)
    
16.                 jg(r, 5) = jg(r, 5) & "," & sz(i, 5)
    
17.                 jg(r, 6) = jg(r, 6) + sz(i, 6)
    
18.                 jg(r, 7) = Round(jg(r, 6) / n, 1)
    
19.         Else
    
20.                h = h + 1: n = 1        '如果字典中未曾出现姓名，则新建一个行号，并记录1次，该次数用于计算平均分
    
21.                dic(sz(i, 3)) = h        '把新生成的行号赋值给字典，key是姓名，value是行号
    
22.                jg(h, 1) = h: jg(h, 7) = Round(jg(h, 6) / n, 1)
    
23.                For j = 2 To cols
    
24.                      jg(h, j) = sz(i, j)
    
25.                Next j
    
26.         End If
    
27. Next i
    
28. 
    
29. Range("a30").Resize(1, cols + 1) = [{"序号","编号","姓名","班级","学科","总分","平均分"}]
    
30. Range("a31").Resize(h, cols + 1) = jg
    
31. 
    
32. End Sub

复制代码

xinxin8899

一把小刀闯天下 发表于 2019-5-21 06:46
Option Explicit

Sub 合并()

简洁明了快速，老师真乃高人，勤奋、执着！