|
- Dim Sh As Worksheet
- Set d = CreateObject("scripting.dictionary")
- Set Sh = Sheet1
- arr = Sh.[a1].CurrentRegion
- For i = 2 To UBound(arr)
- bh = arr(i, 2) '编号
- xm = arr(i, 3)
- d(bh) = d(bh) & "," & i '把相同编号的行数存入字典
- Next
- dk = d.keys: dt = d.items
- Dim brr(1 To 18, 1 To 9) '家庭成员
- Dim crr(1 To 27, 1 To 9) '地籍信息
- For i = 0 To UBound(dk)
- Sheets("模板").Copy after:=Sheets(Sheets.Count)
- xrr = Split(dt(i), ",")
- rk = 0: dj = 0 '人口、地籍数置0
- With ActiveSheet
- For k = 1 To UBound(xrr)
- r = Val(xrr(k))
- xm = arr(r, 3)
- If Len(arr(r, 12)) > 0 Then
- rk = rk + 1
- brr(rk, 1) = arr(r, 12): brr(rk, 2) = arr(r, 14)
- brr(rk, 4) = arr(r, 15): brr(rk, 8) = arr(r, 16)
- End If
- dj = dj + 1
- crr(dj, 1) = arr(r, 11) '地框名称
- crr(dj, 2) = arr(r, 1) '宗地编号
- For j = 3 To 9
- crr(dj, j) = arr(r, j + 1)
- Next
- Next
- .Name = xm
- .[b2] = dk(i)
- .[e2] = xm
- .[h2] = rk
- .[a5].Resize(rk, 4) = brr
- .[a26].Resize(dj, 9) = crr
- End With
- Next
- End Sub
复制代码 |
|