|
本帖最后由 longwin 于 2024-5-27 21:56 编辑
代码优化了一下,附件已更新。
Sub test()
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set sh = Sheets("Sheet1")
Set bg = Workbooks.Open(ThisWorkbook.Path & "\归户确认表.xlsx")
Set mbsh = bg.Sheets("Sheet1")
arr = sh.UsedRange
For i = 1 To sh.UsedRange.Columns.Count '将栏目及对应的列号装入字典
d("【" & sh.Cells(1, i).Value & "】") = i
Next
'按照户主将每户的开始行号及结束行号装入字典
For i = 2 To UBound(arr)
If arr(i, 5) <> "" Then
If i = 2 Then
d1(arr(i, 5)) = Array(i, i)
hz = arr(i, 5)
Else
d1(hz) = Array(d1(hz)(0), i - 1)
d1(arr(i, 5)) = Array(i, i)
hz = arr(i, 5)
End If
End If
Next
For Each Key In d1
ksh = d1(Key)(0) '开始行
jsh = d1(Key)(1) '结束行
Set newbook = Workbooks.Add
mbsh.Copy Before:=newbook.Sheets(1)
Set bgsh = newbook.ActiveSheet
newbookname = ThisWorkbook.Path & "\" & arr(ksh, 4) & ".xlsx"
ssr = Split("4,4|4,13|4,21|5,7|45,4|68,15", "|")
For j = 0 To UBound(ssr)
h = CInt(Split(ssr(j), ",")(0))
l = CInt(Split(ssr(j), ",")(1))
bgsh.Cells(h, l) = arr(ksh, d(bgsh.Cells(h, l).Value))
Next
ssr = Split("10,25|28,36|52,67|70,85", "|")
For j = 0 To UBound(ssr)
k1 = CInt(Split(ssr(j), ",")(0))
k2 = CInt(Split(ssr(j), ",")(1))
For i = k1 To k2
For Each cell In bgsh.Range(bgsh.Cells(i, 1), bgsh.Cells(i, 25))
If Left(cell.Value, 1) = "【" Then
If (i - k1) <= (jsh - ksh) Then
cell.Value = arr(ksh + (i - k1), d(cell.Value))
Else
cell.Value = ""
End If
End If
Next
Next
Next
newbook.SaveAs newbookname
newbook.Close 0
Next
bg.Close
MsgBox "生成完毕!"
Application.ScreenUpdating = True
End Sub
|
评分
-
1
查看全部评分
-
|