VBA实现EXCEL某一列的部分数据和等于指定值

原创 2017年09月07日 18:36:10
Dim sj(), sj1, sj2, jg(), cnt&, d&, h&, hh&, k&, l&, m&, n&, nn&, p&, q&
Sub kagawa()
    tms = Timer
    d = [h3]: l = [h6]: If l = 0 Then l = 65535
    h = [h1] * 10 ^ d: hh = [h2] * 10 ^ d: If hh > h Then hh = hh - h

    If [h7] = 0 Then p = 10 ^ 5 Else p = 10 ^ [h7]

    m = [a1].CurrentRegion.Rows.Count - 1
    n = [h4]: nn = [h5]: If nn = 0 Then If n = 0 Then nn = m Else nn = n
    If Application.Count([d2].Resize(m)) = m And Application.Sum([d2].Resize(m)) = (m + 1) * m / 2 Then
        [a1].CurrentRegion.Sort [d2], 1, , , , , , 1
    Else
        [d2].Resize(m) = "": [d2] = 1: [d2].Resize(m).DataSeries Rowcol:=xlColumns
    End If

    [a2].Resize(m, 5).Sort [c2], 1, , , , , , 2
    sj1 = [a2].Resize(m, 6)
    [e2].Resize(m) = "":
    sj2 = [e2].Resize(m)
    For i = 1 To m
        sj1(i, 1) = 0
        sj1(i, 5) = i
        sj1(i, 6) = sj1(i, 3) * 10 ^ d 'Val2
    Next

    ReDim jg(l, 3)
    k = 0: cnt = 0
    For j = 1 To l
        l = 0
        ReDim sj(m, 6): m = 0
        For i = 1 To UBound(sj1)
            If sj2(i, 1) = "" Then
                m = m + 1
                sj(m, 1) = sj1(i, 1) 'not used now
                sj(m, 2) = sj1(i, 2) 'Code
                sj(m, 3) = sj1(i, 3) 'Val
                sj(m, 4) = sj1(i, 4) 'Row
                sj(m, 5) = sj1(i, 5) 'i
                sj(m, 6) = sj1(i, 6) 'Val2
                sj(m, 0) = sj(m - 1, 0) + sj(m, 6) 'Sum
            End If
        Next
        cnt = 0: q = 0: Call dgH42(h, "", "", m + 1, 1)
        If cnt > p Then Exit For Else CalcCnt = CalcCnt + cnt
        If j > k Then Exit For Else [h6] = k
    Next
    If m Then
        jg(k, 0) = k + 1
        jg(k, 2) = sj(m, 0)
        s = "": t = 0
        For i = 1 To m
            t = t + 1
            s = s & "+" & sj(i, 2)
            sj2(sj(i, 5), 1) = k + 1
        Next
        jg(k, 1) = t
        jg(k, 3) = Mid(s, 2)
        k = k + 1
        [h6] = k
    End If
    If k And k < 65535 Then [k1].CurrentRegion.Offset(1) = "": [k2].Resize(k, 4) = jg

    [e2].Resize(UBound(sj2)) = sj2
    MsgBox "Result: " & k & "/ Calc " & CalcCnt & " Time: " & Format(Timer - tms, "0.000s")

    [a1].CurrentRegion.Sort [e2], 1, [d2], , 1, , , 1
End Sub
Sub dgH42(r&, ri$, ra$, i&, t&)
    Dim j&, t1&, r2&, rs#
    If l Then Exit Sub
    cnt = cnt + 1: If cnt > p Then Exit Sub
'    Exit Sub
    If t >= n And t <= nn Then
        r2 = r + hh
        For j = 1 To i - 1
'            If q Then Stop
            If sj(j, 1) * q Then
'                MsgBox sj(j, 1) & "/" & sj(j, 2) & "/" & q
            Else
                t1 = sj(j, 6) 'Val2
                If r <= t1 And t1 <= r2 Then
                    jg(k, 0) = k + 1
                    jg(k, 1) = t
                    jg(k, 3) = Mid(ra, 2) & "+" & sj(j, 2)
                    rs = 0
                    x = Split(ri & "," & j, ",")
                    For l = 1 To UBound(x)
                        rs = rs + sj1(sj(x(l), 5), 3) 'Val
                        sj2(sj(x(l), 5), 1) = k + 1
                    Next
                    jg(k, 2) = rs
                    k = k + 1
                    Exit Sub
                ElseIf t1 > r2 Then
                    Exit For
                End If
            End If
        Next
    End If
    If t = nn Then Exit Sub

    For j = i - 1 To 2 Step -1
        If sj(j, 1) * q Then
'            MsgBox sj(j, 1) & "/" & sj(j, 2) & "/" & q
        Else
            If sj(j, 6) < r + hh Then 'Val2
                If sj(j, 0) < r Then 'Sum
                    Exit For
                Else
                    If sj(j, 1) Then q = 1
                    Call dgH42(r - sj(j, 6), ri & "," & j, ra & "+" & sj(j, 2), j, t + 1)
                End If
            End If
        End If
    Next

End Sub
Sub mySort()
    sj0 = [a1].CurrentRegion
    m = UBound(sj0) - 1
    k = Application.Sum([d2].Resize(m))
    If Application.Count([d2].Resize(m)) = m And k = (m + 1) * m / 2 Then [a1].CurrentRegion.Sort [d2], 1, , , , , , 1
End Sub

示例文件

版权声明:本文为博主原创文章,未经博主允许不得转载。

相关文章推荐

VBA Excel值数据替换

' 数据替换(原始列右侧数值版) Dim stReplace As Worksheet, stReplaceTextVersion As Worksheet, cReplace As I...

Excel 过滤选择数据后,某个Cell显示其值,并自定义合计的VBA.

Private Sub Worksheet_Calculate() iFindFirstRow = 0 For iRows = 1 To 65536 If Rows(iRows).Hidden ...

在一个excel里面直接批量从谷歌地图抓取经纬度(vba部分)

'http://apps.hi.baidu.com/share/detail/6440301 Function Uri(strText As String) 'Sub Uri()    ...

翻译Excel 2013 Power Programming with VBA 第14章的前两部分

Developing Excel Utilities with VBA 使用VBA开发Excel实用程序   In This Chapter 在这一章 ● Exploring Excel ut...

如何通过excel公式查找一列数据中的相同项目?

公司内部某个部门要进行员工的工作效率的记录,但是要求通过EXCEL进行录入,最后算出综合效率,显示到另外一个表中。 条件: 1、手动录入日期、工号、品番、工时、数量。员工姓名:通过VLOO...

【利用Python进行数据分析——经验篇1】将Excel表中几列合并到一列中

我们都知道,在Excel中可以很容易实现,采用‘A1&B1’ 或者利用CONCATENATE(A1&B1)方式可以实现,但是在Python的pandas包中,本人没有找到合适的用于连接表中两列的函数,...

【Excel】某列数据有效性根据另外一列数据有效性进行动态更改

基本功能需求如下:图1中漏洞的一级分类和二级分类都需要从图2中的sheet里进行选择。若漏洞A的一级分类选择了“一类”,则二级分类对应为“高危、中危、低危”三种;若选择了“二类”,则二级分类为“基础结...

excel 在一列中查找某个值的出现次数 countif函数

Excel中能熟练地掌握函数的技巧,在水文日常工作中能达到事半功倍的效果。例如:要计算A1:An(定义:data)区域中非零的单元格的平均值,可在单元格中输入=sum(data)/countif(da...

Excel VBA利用Transform函数+SQL交叉汇总数据

一、VBA中transform函数基本语法:Creates a crosstab query. Syntax TRANSFORM aggfunction selectstatement PIVOT p...
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:深度学习:神经网络中的前向传播和反向传播算法推导
举报原因:
原因补充:

(最多只允许输入30个字)