|
|
Option Explicit
Sub test()
Dim ar, br, cr, i&, j&, n&, dic(1) As New Dictionary, vKey, Rng As Range
Dim shp As Shape, wks1 As Worksheet, wks2 As Worksheet
DoApp False
Set wks1 = Worksheets("采购计划表")
With wks1
ar = .[A1].CurrentRegion.Value
Set Rng = .Rows("1:3")
For i = 4 To UBound(ar)
If Not dic(0).exists(ar(i, 2)) Then
Set dic(0)(ar(i, 2)) = .Rows(i)
Else
Set dic(0)(ar(i, 2)) = Union(dic(0)(ar(i, 2)), .Rows(i))
End If
dic(1)(ar(i, 2)) = dic(1)(ar(i, 2)) & " " & i
Next
End With
With Workbooks.Add
For Each vKey In dic(0).keys
With .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
ActiveWindow.Zoom = 70
.Name = vKey
rngCopyToSame Rng, .[A1]
br = Split(dic(1)(vKey))
With .[A4].Resize(UBound(br), UBound(ar, 2))
ar = .Value
dic(0)(vKey).Copy .Cells(1, 1)
For i = 1 To UBound(br)
.Cells(i, 1).RowHeight = wks1.Cells(br(i), 1).RowHeight
Next i
For Each shp In .Parent.Shapes
shp.Delete
Next
For i = 1 To UBound(br)
cr = hasPic(wks1.Cells(br(i), 22))
If Join(cr) <> "" Then
n = 2
For j = 1 To UBound(cr)
wks1.Shapes(cr(j)).Copy
With .Cells(i, 22)
.Select
.Parent.Paste
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.Height = .RowHeight - 2
Selection.Top = .Top + 1
Selection.Left = .Left + n
n = Selection.Width + n + 2
End With
Next j
End If
Next i
End With
End With
Next
For Each wks2 In .Worksheets
If wks2.Name Like "*Sheet*" Then wks2.Delete
Next
End With
Erase dic: Set Rng = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
Dim i&
rngSel.Copy
rngTarget.PasteSpecial xlPasteColumnWidths
rngSel.Copy rngTarget
With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
For i = 1 To .Rows.Count
.Rows(i).RowHeight = rngSel.Rows(i).RowHeight
Next i
End With
End Function
Function hasPic(Rng As Range) As String()
Dim shp As Shape, ar$(), r&
For Each shp In Rng.Parent.Shapes
If shp.Type = msoPicture Then
If Abs((shp.Left + shp.Width / 2) - (Rng.Left + Rng.Width / 2)) < (shp.Width + Rng.Width) / 2 And _
Abs((shp.Top + shp.Height / 2) - (Rng.Top + Rng.Height / 2)) < (shp.Height + Rng.Height) / 2 Then
r = r + 1
ReDim Preserve ar(1 To r)
ar(r) = shp.Name
End If
End If
Next
hasPic = ar
End Function
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-2-28 16:34
楼主
