ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2127|回复: 14

[已解决] 组合结果全对就判断为对, 1个结果有错则为错

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-15 07:47 | 显示全部楼层 |阅读模式
本帖最后由 Nsp=娜!再来# 于 2019-1-15 20:09 编辑

条件:
1.  按C:C列【期】数抽取出B:B列中的字母ABCDE的结果(结果是0123456789这10个数字),形成组合F:M列。
2.  每期形成的组合中,必须是全部字母的结果是【对】的,那么这个组合的判断是【对】;否则为【错】。举例如下:
3.  29期的A8:D14形成的组合是F6:L13,其中只有F13:L13是【对】的,M13单元格判断为【对】;其他的都是断为【错】。
4.  F:M列是辅助区域,使用的时候是不存在的,N:W列才是要求的结果。
5.  VBA根据上面的条件,(考虑到数据庞大所以要VBA)

请教
1.  N列相当于求C列删除重复项
2.  计算每期的组合数量在O列,根据M列计算每期【对】的数量在P列,根据M列计算每期【错】的数量在Q列,每个组合中ABCDE共有多少个字母参与的数量在R列。
3.  S:W列是计算每个字母的具体数量。

组合结果全对就判断为对, 1个结果有错则为错.zip (79.51 KB, 下载次数: 10)

请教.png

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 17:13 | 显示全部楼层
感谢lsdongjh老师为我解惑,用lsdongjh老师的代码如下:

  1. Sub test()
  2.     Dim shData As Worksheet
  3.     Dim arr As Variant, lngRow As Long, lngCol As Long
  4.     Dim lngMin As Long, lngMax As Long, lngPeriod As Long
  5.     Dim strPeriod() As String, lngIndex As Long
  6.     Dim strTemp As String, strSplitTemp() As String, strBloon As String
  7.     Dim lngCount() As Long, lngBloon() As Long
  8.     Dim strResult() As Variant, lngTrue As Long
  9.     Dim lngID As Long, lngSum As Long
  10.    
  11.     Set shData = Sheets("Sheet1")
  12.     lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
  13.     arr = shData.Range("A2:D" & lngRow)
  14.    
  15.   '  lngMin = Application.WorksheetFunction.Min(Application.WorksheetFunction.Index(arr, 0, 3))
  16. '   lngMax = Application.WorksheetFunction.Max(Application.WorksheetFunction.Index(arr, 0, 3))
  17.   
  18. 'lngRow = 65537  ,运行ok
  19. '------------------------------------------------------分界线
  20. 'lngRow = 65538  ,运行报错

  21.   
  22.    lngMin = 24 '手动修改最小行
  23.     lngMax = 1048576 '手动修改最大行
  24.    
  25.     ReDim strPeriod(lngMin To lngMax)
  26.     ReDim strResult(0 To lngMax - lngMin + 1, 1 To 10)
  27.     strResult(0, 1) = "期"
  28.     strResult(0, 2) = "组合数量"
  29.     strResult(0, 3) = "对的数量"
  30.     strResult(0, 4) = "错的数量"
  31.     strResult(0, 5) = "字母参与数量"
  32.     strResult(0, 6) = "A的数量"
  33.     strResult(0, 7) = "B的数量"
  34.     strResult(0, 8) = "C的数量"
  35.     strResult(0, 9) = "D的数量"
  36.     strResult(0, 10) = "E的数量"
  37.    
  38.     For lngRow = LBound(arr) To UBound(arr)
  39.         lngPeriod = arr(lngRow, 3)
  40.         strPeriod(lngPeriod) = strPeriod(lngPeriod) & "," & arr(lngRow, 2) & arr(lngRow, 4)
  41.     Next
  42.    
  43.     lngIndex = 0
  44.    
  45.     For lngRow = LBound(strPeriod) To UBound(strPeriod)
  46.         lngIndex = lngIndex + 1
  47.         strResult(lngIndex, 1) = lngRow
  48.         If strPeriod(lngRow) <> "" Then
  49.             ReDim lngCount(1 To 5) As Long
  50.             ReDim lngBloon(1 To 5) As Long
  51.             strSplitTemp = Split(strPeriod(lngRow), ",")
  52.             For lngID1 = 1 To UBound(strSplitTemp)
  53.                 strTemp = Mid(strSplitTemp(lngID1), 1, 1)
  54.                 strBloon = right(strSplitTemp(lngID1), 1)
  55.                 Select Case UCase(strTemp)
  56.                     Case "A", "B", "C", "D", "E"
  57.                         lngID = Asc(UCase(strTemp)) - 64
  58.                         lngCount(lngID) = lngCount(lngID) + 1
  59.                         If strBloon = "对" Then lngBloon(lngID) = lngBloon(lngID) + 1
  60.                End Select
  61.             Next
  62.             lngID = 0: lngSum = 1: lngTrue = 1
  63.             For lngCol = 1 To 5
  64.                 If lngCount(lngCol) > 0 Then
  65.                     lngTrue = lngTrue * lngBloon(lngCol)
  66.                     lngID = lngID + 1
  67.                     lngSum = lngSum * lngCount(lngCol)
  68.                 End If
  69.             Next
  70.             strResult(lngIndex, 2) = lngSum
  71.             strResult(lngIndex, 3) = lngTrue
  72.             strResult(lngIndex, 4) = lngSum - lngTrue
  73.             strResult(lngIndex, 5) = lngID
  74.             strResult(lngIndex, 6) = lngCount(1)
  75.             strResult(lngIndex, 7) = lngCount(2)
  76.             strResult(lngIndex, 8) = lngCount(3)
  77.             strResult(lngIndex, 9) = lngCount(4)
  78.             strResult(lngIndex, 10) = lngCount(5)
  79.             
  80.          Else
  81.             For lngCol = 2 To 10
  82.                 strResult(lngIndex, lngCol) = 0
  83.             Next
  84.         End If
  85.         
  86.     Next
  87.    
  88.     shData.Range("F1:O" & Rows.Count).Clear
  89.     shData.Range("F1").Resize(UBound(strResult) + 1, 10) = strResult
  90. End Sub
复制代码


TA的精华主题

TA的得分主题

发表于 2019-1-15 12:05 | 显示全部楼层
  1. Sub Test()
  2.     Dim shData As Worksheet
  3.     Dim arr As Variant, lngRow As Long, lngCol As Long
  4.     Dim lngMin As Long, lngMax As Long, lngPeriod As Long
  5.     Dim strPeriod() As String, lngIndex As Long
  6.     Dim strTemp As String, strSplitTemp() As String, strBloon As String
  7.     Dim lngCount() As Long, lngBloon() As Long
  8.     Dim strResult() As Variant, lngTrue As Long
  9.     Dim lngID As Long, lngSum As Long
  10.    
  11.     Set shData = Sheets("Sheet1")
  12.     lngRow = shData.Range("A" & Rows.Count).End(xlUp).Row
  13.     arr = shData.Range("A2:D" & lngRow)
  14.    
  15.     lngMin = Application.WorksheetFunction.Min(Application.WorksheetFunction.Index(arr, 0, 3))
  16.     lngMax = Application.WorksheetFunction.Max(Application.WorksheetFunction.Index(arr, 0, 3))
  17.    
  18.     ReDim strPeriod(lngMin To lngMax)
  19.     ReDim strResult(0 To lngMax - lngMin + 1, 1 To 10)
  20.     strResult(0, 1) = "期"
  21.     strResult(0, 2) = "组合数量"
  22.     strResult(0, 3) = "对的数量"
  23.     strResult(0, 4) = "错的数量"
  24.     strResult(0, 5) = "字母参与数量"
  25.     strResult(0, 6) = "A的数量"
  26.     strResult(0, 7) = "B的数量"
  27.     strResult(0, 8) = "C的数量"
  28.     strResult(0, 9) = "D的数量"
  29.     strResult(0, 10) = "E的数量"
  30.    
  31.     For lngRow = LBound(arr) To UBound(arr)
  32.         lngPeriod = arr(lngRow, 3)
  33.         strPeriod(lngPeriod) = strPeriod(lngPeriod) & "," & arr(lngRow, 2) & arr(lngRow, 4)
  34.     Next
  35.    
  36.     lngIndex = 0
  37.    
  38.     For lngRow = LBound(strPeriod) To UBound(strPeriod)
  39.         lngIndex = lngIndex + 1
  40.         strResult(lngIndex, 1) = lngRow
  41.         If strPeriod(lngRow) <> "" Then
  42.             ReDim lngCount(1 To 5) As Long
  43.             ReDim lngBloon(1 To 5) As Long
  44.             strSplitTemp = Split(strPeriod(lngRow), ",")
  45.             For lngID1 = 1 To UBound(strSplitTemp)
  46.                 strTemp = Mid(strSplitTemp(lngID1), 1, 1)
  47.                 strBloon = Right(strSplitTemp(lngID1), 1)
  48.                 Select Case UCase(strTemp)
  49.                     Case "A", "B", "C", "D", "E"
  50.                         lngID = Asc(UCase(strTemp)) - 64
  51.                         lngCount(lngID) = lngCount(lngID) + 1
  52.                         If strBloon = "对" Then lngBloon(lngID) = lngBloon(lngID) + 1
  53.                End Select
  54.             Next
  55.             lngID = 0: lngSum = 1: lngTrue = 1
  56.             For lngCol = 1 To 5
  57.                 If lngCount(lngCol) > 0 Then
  58.                     lngTrue = lngTrue * lngBloon(lngCol)
  59.                     lngID = lngID + 1
  60.                     lngSum = lngSum * lngCount(lngCol)
  61.                 End If
  62.             Next
  63.             strResult(lngIndex, 2) = lngSum
  64.             strResult(lngIndex, 3) = lngTrue
  65.             strResult(lngIndex, 4) = lngSum - lngTrue
  66.             strResult(lngIndex, 5) = lngID
  67.             strResult(lngIndex, 6) = lngCount(1)
  68.             strResult(lngIndex, 7) = lngCount(2)
  69.             strResult(lngIndex, 8) = lngCount(3)
  70.             strResult(lngIndex, 9) = lngCount(4)
  71.             strResult(lngIndex, 10) = lngCount(5)
  72.             
  73.          Else
  74.             For lngCol = 2 To 10
  75.                 strResult(lngIndex, lngCol) = 0
  76.             Next
  77.         End If
  78.         
  79.     Next
  80.    
  81.     shData.Range("N30:w" & Rows.Count).Clear
  82.     shData.Range("N30").Resize(UBound(strResult) + 1, 10) = strResult
  83. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 13:54 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 Nsp=娜!再来# 于 2019-1-15 14:04 编辑

A到D列多行就运行时错误,类型13.zip (1.9 MB, 下载次数: 7)
A:D列有很多行的时候,就出现“ 运行时错误'13' ”以及“类型不匹配”的提示,
原始数据有100万行的,因为附件上传限制2M以内,这里的附件我只附上113008行,
附件中,我把结果显示在F1:O列了,

请完善,麻烦老师了!


TA的精华主题

TA的得分主题

发表于 2019-1-15 14:01 | 显示全部楼层
Nsp=娜!再来# 发表于 2019-1-15 13:54
A:D列有很多行的时候,就出现“ 运行时错误'13' ”以及“类型不匹配”的提示,
原始数据有100万行的 ...

运行正常,无错误啊

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 14:07 | 显示全部楼层
lsdongjh 发表于 2019-1-15 14:01
运行正常,无错误啊

提示1

提示1

提示2

提示2



我的电脑是WIN7的64位,出现这样的情况,请帮忙修正。

TA的精华主题

TA的得分主题

发表于 2019-1-15 14:21 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-1-15 14:22 | 显示全部楼层
lngRow = 65537  ,运行ok
------------------------------------------------------分界线
lngRow = 65538  ,运行报错

TA的精华主题

TA的得分主题

发表于 2019-1-15 15:42 | 显示全部楼层
'75.36s    组合数:43379885

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, kkk, m, n, dic, t, p, sum, a, tt
  Dim i1, i2, i3, i4, i5
  tt = Timer
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Offset(1)
  ReDim crr(1 To 10 ^ 5, 1 To 8) As String
  ReDim drr(1 To UBound(arr, 1), 1 To 10)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 3) <> arr(j + 1, 3) Then
        Call dsort(arr, i, j, 1, UBound(arr, 2), 2)
        ReDim brr(1 To 5, 1 To 20) As String, cnt(1 To 5) As Integer
        m = 1: n = 0: dic.RemoveAll
        ReDim sum(65 To 69)
        For k = i To j
          n = n + 1: brr(m, n) = arr(k, 2)
          If left(arr(k, 2), 1) <> left(arr(k + 1, 2), 1) Then
            cnt(m) = n: m = m + 1: n = 0
          End If
          dic(arr(k, 2)) = arr(k, 4)
          t = Asc(left(arr(k, 2), 1))
          sum(t) = sum(t) + 1
        Next
        For k = 1 To UBound(cnt)
          If cnt(k) = 0 Then cnt(k) = 1
        Next
        t = 0: p = kk: kkk = 0
        For i1 = 1 To cnt(1)
          For i2 = 1 To cnt(2)
            For i3 = 1 To cnt(3)
              For i4 = 1 To cnt(4)
                For i5 = 1 To cnt(5)
                  kk = kk + 1: kkk = kkk + 1
                  crr(kkk, 7) = arr(i, 3): crr(kkk, 1) = kkk
                  crr(kkk, 2) = brr(1, i1): crr(kkk, 3) = brr(2, i2)
                  crr(kkk, 4) = brr(3, i3): crr(kkk, 5) = brr(4, i4): crr(kkk, 6) = brr(5, i5)
                  For k = 2 To 6
                    If dic(crr(kkk, k)) = "错" Then Exit For
                  Next
                  If k = 7 Then t = t + 1
        Next i5, i4, i3, i2, i1
        a = a + 1
        drr(a, 1) = arr(i, 3): drr(a, 2) = kk - p: drr(a, 3) = t: drr(a, 4) = drr(a, 2) - t
        t = 0
        For k = 6 To 10
          drr(a, k) = sum(59 + k)
          If Len(drr(a, k)) Then t = t + 1
        Next
        drr(a, 5) = t: p = kk
        i = j: Exit For
      End If
  Next j, i
  With [f2]
    .Resize(UBound(arr, 1), UBound(drr, 2)).ClearContents
    .Resize(a, UBound(drr, 2)) = drr
  End With
  Debug.Print Format(Timer - tt, "0.00s")  ,  "组合数:" & kk
End Sub

Function dsort(arr, first, last, left, right, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) > arr(j, key) Then
        For k = left To right
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-15 15:46 | 显示全部楼层
Nsp=娜!再来# 发表于 2019-1-15 13:54
A:D列有很多行的时候,就出现“ 运行时错误'13' ”以及“类型不匹配”的提示,
原始数据有100万行的, ...

    lngMin = Application.WorksheetFunction.Min(Application.WorksheetFunction.Index(arr, 0, 3))
    lngMax = Application.WorksheetFunction.Max(Application.WorksheetFunction.Index(arr, 0, 3))

如果是停留在这两句,你可以直接输入最小的期号,和最大的期号,试一下,如
    lngMin =12
    lngMax =8999

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 17:03 | 显示全部楼层
一把小刀闯天下 发表于 2019-1-15 15:42
'75.36s    组合数:43379885

Option Explicit

谢谢老师的帮助!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-28 22:58 , Processed in 0.063737 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表