|
|
Sub test()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
lj = ThisWorkbook.Path & "\照片\"
Set Sht = Sheets("模板")
With Sheets("信息表")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 7 Then MsgBox "信息表为空！": End
ar = .Range("a1:g" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
d(Trim(ar(i, 1))) = ""
End If
Next i
For Each k In d.keys
n = 0: w = w + 1
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
If n / 4 = Int(n / 4) Then
gs = n / 4
Else
gs = Int(n / 4) + 1
End If
If w = 1 Then
Sht.Copy
Set wb = ActiveWorkbook
With wb.Worksheets(1)
.Name = k
If n > 4 Then
m = 11
For s = 1 To gs - 1
.Rows("3:10").Copy .Cells(m, 1)
m = m + 10
Next s
End If
m = 3
For i = 1 To n Step 4
y = 2
For s = i To i + 3
If s <= r Then
.Cells(m, y) = br(s, 2)
.Cells(m + 1, y) = br(s, 3)
.Cells(m + 2, y) = br(s, 4)
.Cells(m + 3, y) = br(s, 5)
.Cells(m + 6, y + 1) = br(s, 6)
.Cells(m + 7, y + 1) = br(s, 7)
tp = Dir(lj & br(s, 2) & ".jpeg")
If tp <> "" Then
.Cells(m, y + 2).Resize(4, 1).Select
cellL = ActiveCell.Left + 3
cellT = ActiveCell.Top
Set shpPic = ActiveSheet.Shapes.AddPicture(lj & tp, msoFalse, msoTrue, cellL, cellT, 1, 1)
shpPic.Top = .Cells(m, y + 2).Resize(4, 1).Top + 1
shpPic.Left = .Cells(m, y + 2).Resize(4, 1).Left + 1
shpPic.Width = .Cells(m, y + 2).Resize(4, 1).Width - 1
shpPic.Height = .Cells(m, y + 2).Resize(4, 1).Height - 1
Set shpPic = Nothing
End If
y = y + 4
End If
Next s
m = m + 10
Next i
End With
Else
Sht.Copy after:=wb.Worksheets(wb.Worksheets.Count)
With wb.Worksheets(wb.Worksheets.Count)
.Name = k
If n > 4 Then
m = 11
For s = 1 To gs - 1
.Rows("3:10").Copy .Cells(m, 1)
m = m + 10
Next s
End If
m = 3
For i = 1 To n Step 4
y = 2
For s = i To i + 3
If s <= r Then
.Cells(m, y) = br(s, 2)
.Cells(m + 1, y) = br(s, 3)
.Cells(m + 2, y) = br(s, 4)
.Cells(m + 3, y) = br(s, 5)
.Cells(m + 6, y + 1) = br(s, 6)
.Cells(m + 7, y + 1) = br(s, 7)
tp = Dir(lj & br(s, 2) & ".jpeg")
If tp <> "" Then
.Cells(m, y + 2).Resize(4, 1).Select
cellL = ActiveCell.Left + 3
cellT = ActiveCell.Top
Set shpPic = ActiveSheet.Shapes.AddPicture(lj & tp, msoFalse, msoTrue, cellL, cellT, 1, 1)
shpPic.Top = .Cells(m, y + 2).Resize(4, 1).Top + 1
shpPic.Left = .Cells(m, y + 2).Resize(4, 1).Left + 1
shpPic.Width = .Cells(m, y + 2).Resize(4, 1).Width - 1
shpPic.Height = .Cells(m, y + 2).Resize(4, 1).Height - 1
Set shpPic = Nothing
End If
y = y + 4
End If
Next s
m = m + 10
Next i
End With
End If
Next k
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & Format(Date, "yyyy年m月") & "毕业生花名册.xlsx"
wb.Close
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-7-25 21:37
楼主
