Office中国论坛/Access中国论坛

标题: 交集差集，想加入个表头，难度大。。。。 [打印本页]

作者: 海孩 时间: 2008-1-11 20:35
标题: 交集差集，想加入个表头，难度大。。。。
在期初、期末余额表加一个表头，统计后在减少客户名单、增减客户名单、老客户名单表里自动产生对应的表头。

表头如下：
单位金额1 金额2 。。。类别备注

作者: 欢欢 时间: 2008-1-12 10:24
难度不大也

作者: ui 时间: 2008-1-12 11:35
感谢欢欢分享, 学习一下

作者: 海孩 时间: 2008-1-12 12:57
谢谢欢欢，搞定，回去测试一下几万条大数据量的速度。另外su45写的代码如何？哪种速度会快些？

Sub suaa()
Dim arr1(), arr2(), arr3()
r = [A65536].End(xlUp).Row
rng1 = Range("A2:A" & r)
rng2 = Range("A2:E" & r)
With Sheets("期末余额表")
r = .[A65536].End(xlUp).Row
rng3 = .Range("A2:A" & r)
rng4 = .Range("A2:E" & r)
End With
rng1 = Application.Transpose(rng1)
rng3 = Application.Transpose(rng3)
For i = 1 To UBound(rng3)
If UBound(Filter(rng1, rng3(i))) > -1 Then
      n = n + 1
      ReDim Preserve arr3(1 To 5, 1 To n)
      For j = 1 To 5
         arr3(j, n) = rng4(i, j)
      Next
Else
      m = m + 1
      ReDim Preserve arr2(1 To 5, 1 To m)
      For j = 1 To 5
         arr2(j, m) = rng4(i, j)
      Next
End If
Next
For i = 1 To UBound(rng1)
If UBound(Filter(rng3, rng1(i))) = -1 Then
      k = k + 1
      ReDim Preserve arr1(1 To 5, 1 To k)
      For j = 1 To 5
         arr1(j, k) = rng2(i, j)
      Next
End If
Next
With Sheets("减少的客户名单")
r = .[A65536].End(xlUp).Row
If r > 2 Then .Range("A3:C" & r).ClearContents
.[A3].Resize(k, 5) = Application.Transpose(arr1)
End With
With Sheets("新增的客户名单")
r = .[A65536].End(xlUp).Row
If r > 2 Then .Range("A3:C" & r).ClearContents
.[A3].Resize(m, 5) = Application.Transpose(arr2)
End With
With Sheets("老客户名单")
r = .[A65536].End(xlUp).Row
If r > 2 Then .Range("A3:C" & r).ClearContents
.[A3].Resize(n, 5) = Application.Transpose(arr3)
End With
End Sub

[ 本帖最后由海孩于 2008-1-12 13:59 编辑 ]

作者: tmtony 时间: 2008-1-12 13:33
学习学习了

作者: yygyalo 时间: 2008-1-17 09:27
學習中,幾萬條的速度應該很慢吧!

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)