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如何在工作表区域内查找某个值,发回这个值所在的行号、列号

用VBA代码编写,如何在工作表区域内查找某个值,发回这个值所在的行号、列号 spwangxu | 浏览 7128 次 推荐于2016-01-0...
  • Goldxwang
  • Goldxwang
  • 2017年07月04日 10:22
  • 994

VBA 从一个excel读取特定行,列到指定excel

Private Function splitExcelName(row, myFileName) As String 'This function will get task ID, subtask...
  • shibixiao
  • shibixiao
  • 2013年09月09日 14:30
  • 4995

excel 两个sheet根据相同列 提取某一列的值

sheet1 2列 DeviceL1_ID DeployDevice_IP 0000000001 172.24.9.12 0000000002 ...
  • AlbertFly
  • AlbertFly
  • 2017年06月08日 11:48
  • 543

Excel VBA将某列数值存入一个数组

Sub test() Dim arr() As String '定义动态数组 Dim n As Long Dim i As Integ...
  • ChristopherChen
  • ChristopherChen
  • 2016年11月27日 23:54
  • 3886

怎样将Excel中的某一部分字段内容导入到SQL Server 2000的某个表的某些字段中

 很简单,使用opendatasource就可以实现了insert into tablenameselect * from opendatasource(Microsoft.Jet.OLEDB.4.0...
  • itzhiren
  • itzhiren
  • 2006年10月13日 14:15
  • 1692

【VBA研究】用VBA取得EXCEL任意列有效行数

作者:iamlaosong 用VBA对Excel文件进行处理的时候,关键字段的列号编程时往往是不知道的,需要通过参数设定才能知道,因此,我们编程的时候,就不能用这样的语句取有效行数: lineno =...
  • iamlaosong
  • iamlaosong
  • 2015年07月21日 11:57
  • 2853

5, excel vba 修改单元格里的数据

通过上节学习,我们己经学会了往一个单元格里写入数据,接下来,我们整合前两节的内容. 把一个单元格的数据进行修改 我们看到,在单元格 A1中,有一个数据100, 接下来我们要给它后面加上:美元 .  ...
  • keepiss
  • keepiss
  • 2018年01月23日 09:21
  • 45

用Java技术读取Excel文件中的某列的所有值

所需jar包:poi-3.6-20091214.jar 样例文件如下: 现在的目标是要把A,B,C,D,E,F,G这些值取出来,然后打印. public static void main(String...
  • liuxiIT
  • liuxiIT
  • 2010年07月15日 17:48
  • 13435

Excel_取得某栏(列)最后非空格的值

这个问题用VBA很容易,下面的一个叙述就可以取得A栏最后非空储存格的值。MsgBox Range("A65536").End(xlUp)但是使用公式来做的话,则需要具备一点想象力。 我记得有一个这样的...
  • xg_an
  • xg_an
  • 2006年07月08日 23:21
  • 1693

Excel 某单元格查找在某列中是否存在,存在就插入或拷贝值到指定单元格 VLOOKUP IF嵌套用法

=VLOOKUP(IF(LEN(D3) 是否可以看懂上面的公式?如果看的懂以下文字看也是白看了 现在有一个问题是要从在,表:公司36396中查出“用户名称”与“用户编号”拷贝到,表:Sheet1中...
  • daihongliu
  • daihongliu
  • 2011年10月20日 14:46
  • 9435
内容举报
返回顶部
收藏助手
不良信息举报
您举报文章:VBA实现EXCEL某一列的部分数据和等于指定值
举报原因:
原因补充:

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