|
本帖最后由 lwfzjs 于 2017-7-20 10:07 编辑
蓝桥玄霜老师您好:
你在http://club.excelhome.net/thread-1358098-2-1.html里帮我编的VBA 我在表格中Set d = CreatObject("Scripting. Dictonary")运行出现了问题, 麻烦你帮忙看看 我抄写过程出现了什么问题 Set r1 = rng. Find(Arr(i, j), , , 1) 这里显示有问题
sub test()
Dim arr, i&, rng As Range, r1, j&, aa, a, mx, n&
Dim d, k, t, d1, k1, t1, Brr, r%, Arr1(), rr%, Arr2()
Set d = CreatObject("Scripting. Dictonary")
Set d1 = CreatObject("Scripting. Dictonary")
Sheet1. Activate
[aq3:bg5000]. ClearContents
Arr = [b1].CurrentRegion
Brr = [i1].CurrentRegion
for i =3 TO UBound(Arr)
Set rag = Cells(i, 9). Resize(1, 33)
For j = 1 To UBound(Arr, 2)
Set r1 = rng. Find(Arr(i, j), , , 1)
d(r1. Coumn - 8) = ""
Next
k = d.keys: r = 0: rr = 0
ReDim a(33)
For j = O To UBound(k)
a(K(j)) = k(j)
Next
For j = O To UBound(a)
If a(j) <> "" Then
r = r + 1
ReDim Preserve Arr1(1 To r)
Arr1(r) = a(j)
End If
Next
For j = 1 To r
If j = 1 Then aa = Arr1(j) - 1 Else aa = Arr1(j) - Arr(j - 1) - 1
rr = rr + 1
ReDim Preserve Arr2(1 To rr)
Arr2(rr) = aa
Next
Arr2(1) = Arr2(1) + 33 - Arr1(r)
For j = 1 To r
d1(Arr2(j)) = d1(Arr2(j)) & j & ","
Next
k1 = d1. keys: t1 = d1. items: col = 42
mx = Application. Max(Arr2)
n = Application. Match(mx, k1, 0) - 1
t = t1(n)
t = left(t, Len(t) - 1)
If InStr(t, ",") Then
aa = Split(t, ",")
For j = O To UBound(aa)
Call tb(i, Val(aa(j)), r, Arrl, Brr)
Next
Else
Call tb(i, Val(t), r, Arr1, Brr)
End IF
d.RemoveALL
d1.RemoveALL
Next
End Sub
sub tb(i, n, r, Arr1, Brr)
Dim j&
If n <> 1 Then
For j = Arr(n - 1) + 1 To Arr1(n) - 1
col = col + 1
cells(i,col) = Format(Brr(i, j), "00")
Next
Else
If Arr1(r) <> 33 Then
For j = Arr1(r) + 1 To 33
col = col + 1
Cells(i, col) = Format(Brr(i, j), "00")
Next
End If
if Arr1(1) <> 1 Then
For j = 1 To Arr1(1) - 1
col = col + 1
Cells(i, col) = Format(Brr(i, j), "00")
Next
End If
End If
End sub
|
|