|
Sub 批量()
Application.ScreenUpdating = False
Dim ar As Variant
Dim arr()
Application.DisplayAlerts = False
For Each sh In Sheets
If sh.Index > 2 Then
sh.Delete
End If
Next sh
Application.DisplayAlerts = True
ar = Sheets("数据源").[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 5)) = "户主" Then
hs = ar(i, 10)
n = 0
ReDim arr(1 To hs, 1 To 9)
For s = i To i + hs - 1
n = n + 1
arr(n, 1) = n
arr(n, 2) = ar(i, 1)
arr(n, 3) = ar(i, 4)
arr(n, 4) = ar(i, 2)
arr(n, 5) = ar(i, 5)
arr(n, 6) = ar(i, 7)
arr(n, 7) = ar(i, 8)
arr(n, 9) = ar(i, 9)
Next s
Sheets("家庭收入采集表").Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = ar(i, 1) & "_" & ar(i, 2)
.[a3].Resize(n, UBound(arr, 2)) = arr
.[b10] = ar(i, 11)
.[d10] = ar(i, 12)
.[f10] = ar(i, 13)
.[h10] = ar(i, 14)
.[j10] = ar(i, 15)
End With
End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|