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

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

• 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
• 2013年09月09日 14:30
• 4995

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

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

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

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

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

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

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

• iamlaosong
• 2015年07月21日 11:57
• 2853

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

• keepiss
• 2018年01月23日 09:21
• 45

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

• liuxiIT
• 2010年07月15日 17:48
• 13435

## Excel_取得某栏（列）最后非空格的值

• xg_an
• 2006年07月08日 23:21
• 1693

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

=VLOOKUP(IF(LEN(D3) 是否可以看懂上面的公式？如果看的懂以下文字看也是白看了 现在有一个问题是要从在，表：公司36396中查出“用户名称”与“用户编号”拷贝到，表：Sheet1中...
• daihongliu
• 2011年10月20日 14:46
• 9435

举报原因： 您举报文章：VBA实现EXCEL某一列的部分数据和等于指定值 色情 政治 抄袭 广告 招聘 骂人 其他 (最多只允许输入30个字)