这次读的数据相当多，表格还很LOW

teshia

又是这种合并单元格，相当多的数据
说明：sheet表中有 XX数据；XX数据...
为原始数据；
说明1：实验状态率：有文字描述的，算1个状态，无描述为0，具体见J列
说明2：实际数据量较大，先列这几个。每一种分类下面的研究说明项是一致的。
原始表一：后面还有二和三，分别是 XX数据


表一中 问题点数，此列，就是物理研究中有3个研究样本点位。物理研究的第一项“形式多样，有自行设计特色”的失分率就是，0/3个样本＝0%
其余类似

效果表为最终目的
备注1：所有人的研究行业是相同的大类，只是研究的样本点位不同
备注2：失分率为问题数/样本点位数



测评实验问题率.rar (28.42 KB, 下载次数: 6)

2018-7-12 07:13 上传

点击文件名下载附件

microyip

并非学习，为求解决工作，应该有偿去请专业人士去做，老是来论坛贪这种免费代工

teshia

microyip 发表于 2018-7-12 08:10
并非学习，为求解决工作，应该有偿去请专业人士去做，老是来论坛贪这种免费代工

microyip 说的对。

是为解决工作。

不过 也在学习，不过没琢磨出来。我自己还是先琢磨琢磨吧

teshia

microyip 发表于 2018-7-12 08:10
并非学习，为求解决工作，应该有偿去请专业人士去做，老是来论坛贪这种免费代工

其实我真的在学习，在消化。可能消化的过程 ，是以 实用为主，遇到哪块有问题，学哪块，不够系统。

经过两天的摸索，我自己搞定了单个 sheet表的，读取出来所有的数据。还没加上遍历

写的方法很笨拙，但达到目的了。过几天有时间再改改。

1. Sub 读取点位数()
   
2.   Dim i, j, k, sl, sum, arr, brr()
   
3.   Application.Calculation = xlCalculationManual '手动重算
   
4.   Sheet2.Activate
   
5.   Sheet2.Range("D2:I24").ClearContents
   
6. ‘Title = Split("行业 测评点位 得分 测评项目数")
   
7.   Rows1 = Sheets("李明数据").UsedRange.Rows.Count
   
8.   arr = Sheet1.Range("a1:j" & Rows1)
   
9.   ReDim brr(1 To UBound(arr, 1), 1 To 4)
   
10.   ReDim crr(1 To UBound(arr, 1), 1 To 8)
    
11.   sk = 0
    
12.   j = 1
    
13.   With Sheets("李明数据")
    
14. For i = 1 To UBound(arr, 1) - 1
    
15. If arr(i, 1) <> "" And arr(i, 3) <> "" Then                     ' And arr(i, 3) <> "研究点位"
    
16. k = Sheet1.Cells(i, 1).MergeArea.Rows.Count
    
17.     sum = 0
    
18.     If k = 1 Then                                                '单行表格不计入行数
    
19.     sk = Sheet1.Cells(i + 1, 1).MergeArea.Rows.Count
    
20.     End If
    
21.         If i > 4 And arr(i - 1, 1) = "研究点位" Then                                          '单行表格不计入行数
    
22.             stpk = stpk + oldk
    
23.         End If
    
24. 
    
25.         If k = sk Then                                                '单行表格不计入行数
    
26.             For sl = 1 To k
    
27.                 If arr(i, 5) > 0 Then
    
28.                 sum = sum + Val(arr(i + sl - 1, 5))
    
29.                 crr(sl + stpk, 1) = crr(sl + stpk, 1) + Val(arr(i + sl - 1, 10))
    
30.                 End If
    
31.             Next
    
32.             brr(j, 1) = arr(i, 1)
    
33.             brr(j, 2) = arr(i, 6)
    
34.             brr(j, 3) = sum
    
35.             brr(j, 4) = k
    
36.             j = j + 1
    
37.         End If
    
38.     End If
    
39.     If k > 1 Then
    
40.     oldk = k
    
41.     End If
    
42.     Next
    
43. End With
    
44. Sheet2.[J2].Resize(UBound(brr, 1) - 1, UBound(brr, 2)) = brr
    
45. Sheet2.[N2].Resize(UBound(crr, 1) - 1, 1) = crr
    
46. Application.Calculation = xlCalculationAutomatic '自动重算
    
47. End Sub
    

复制代码

teshia

microyip 发表于 2018-7-12 08:10
并非学习，为求解决工作，应该有偿去请专业人士去做，老是来论坛贪这种免费代工

遍历工作表，也调试成功了，还是非常感谢你

静下心，用循环硬磨把磨出来了，边循环边改
晕，怎么有代码的就要审核，这第二段纯是文字反而发出来了

microyip

teshia 发表于 2018-7-13 15:55
遍历工作表，也调试成功了，还是非常感谢你

静下心，用循环硬磨把磨出来了，边循环边改

虽然没有时间详细看或测试你的码，但你能自己动手，无论对错，都是成功的第一步，给你先点赞