Option Explicit
Sub TEST1()
Dim ar, br, cr, dr, i&, j&, r&, k&, dic As Object, vKey
Dim strFileName$, strPath$, wks As Worksheet, iPosRow&
strPath = ThisWorkbook.Path & "\"
strFileName = strPath & "04送货单(模板).xlsm"
If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set dic = CreateObject("Scripting.Dictionary")
br = [M1:T2].Value
dr = [{"B2",1;"B3",2;"F2",3;"F3",4;"H2",5;"H3",6;"D15",7;"I15",8}]
For j = 1 To UBound(br, 2)
If j = 1 Or j = 2 Then br(2, j) = br(1, j) & br(2, j)
dr(j, 2) = br(2, j)
Next j
r = Cells(Rows.Count, "B").End(xlUp).Row
ar = Range("A1:I" & r).Value
For i = 3 To UBound(ar)
dic(ar(i, 2)) = dic(ar(i, 2)) & " " & i
Next i
With GetObject(strFileName)
Set wks = .Worksheets(1)
With Workbooks.Add
For Each vKey In dic.keys
cr = Split(dic(vKey))
ReDim br(1 To UBound(cr), 1 To 8)
For i = 1 To UBound(cr)
For j = 2 To UBound(br, 2)
br(i, j) = ar(cr(i), j + 1)
Next j
br(i, 1) = ar(cr(i), 1)
Next i
br = cutArray(br, 8)
For i = 1 To UBound(br)
wks.Copy after:=.Worksheets(.Worksheets.Count)
With ActiveSheet
.Name = vKey & "-" & i
For j = 1 To 3
iPosRow = IIf(j = 1, 1, (j - 1) * 17)
With .Cells(iPosRow, 1)
For k = 1 To UBound(dr)
.Range(dr(k, 1)) = dr(k, 2)
Next k
.Cells(5, 2).Resize(UBound(br(i)), UBound(br(i), 2)) = br(i)
End With
Next j
End With
Next i
Next
For Each wks In .Worksheets
If wks.Name Like "*Sheet*" Then wks.Delete
Next
End With
.Close False
End With
Call CreateList
Set dic = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Beep
End Sub
Function cutArray(ByVal ar, iCutNum&) As Variant
Dim br(), cr, i&, j&, iPosRow&, r&, k&
For i = 1 To UBound(ar) Step iCutNum
iPosRow = IIf((i + iCutNum - 1) > UBound(ar), UBound(ar) Mod iCutNum, iCutNum)
ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
For j = 1 To UBound(cr)
For k = 1 To UBound(cr, 2)
cr(j, k) = ar(i - 1 + j, k)
Next k
Next j
r = r + 1
ReDim Preserve br(1 To r)
br(r) = cr
Next i
cutArray = br
End Function
Function CreateList()
Dim i&
Worksheets.Add(before:=Worksheets(1)).Name = "工作表目录"
[A1].Resize(, 2) = [{"序号", "日期"}]
For i = 2 To Worksheets.Count
Cells(i, 1).Value = i - 1
ActiveSheet.Hyperlinks.Add Cells(i, 2), "", "'" & Worksheets(i).Name & "'" & "!B1", _
"单击打开：" & Worksheets(i).Name, Worksheets(i).Name
Worksheets(i).Hyperlinks.Add Worksheets(i).Cells(1, 2), "", _
Worksheets(1).Name & "!B" & i, "返回目录"
Next i
Columns("A:B").AutoFit
End Function
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-3 20:39
楼主
