|
|
- Sub lqxs()
- Dim Arr, i&, x, Arr1, myPath$, myName$, r%, Brr()
- Dim d, k, t, aa, j&, n&
- Set d = CreateObject("Scripting.Dictionary")
- Application.ScreenUpdating = False
- myPath = ThisWorkbook.Path & ""
- myName = "记账辅助b.xls"
- With GetObject(myPath & myName)
- Arr1 = .Sheets(1).Range("A1").CurrentRegion
- For i = 2 To UBound(Arr1)
- x = Arr1(i, 1)
- d(x) = d(x) & i & ","
- Next
- .Close False
- End With
- k = d.keys: t = d.items
- Sheet1.Activate
- Arr = Sheet1.UsedRange
- For i = 1 To UBound(Arr)
- If InStr(Arr(i, 1), "单位") Then
- r = r + 1
- ReDim Preserve Brr(1 To r)
- Brr(r) = i
- End If
- Next
- For i = 0 To UBound(k)
- n = Brr(i + 1)
- Cells(n, 4) = "记字第" & k(i) & "号"
- t(i) = Left(t(i), Len(t(i)) - 1)
- If InStr(t(i), ",") Then
- aa = Split(t(i), ",")
- For j = 0 To UBound(aa)
- Cells(n + j + 2, 1) = Arr1(aa(j), 2): Cells(n + j + 2, 3) = Arr1(aa(j), 4)
- Next
- Else
- Cells(n + 2, 1) = Arr1(t(i), 2): Cells(n + 2, 3) = Arr1(t(i), 4)
- End If
- Next
- Application.ScreenUpdating = True
- End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2016-11-8 13:19
楼主
发表于 2016-11-8 17:23
