|
Sub 生成实验报告()
Application.ScreenUpdating = False
Dim ar As Variant
With Sheets("清单")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "清单为空!": End
ar = .Range("a1:p" & r)
End With
Set sh = Sheets("模板")
b = Array(12, 14, 16)
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
zd = ar(i, 2) & " " & ar(i, 3) & " " & ar(i, 4) & " " & ar(i, 7)
For s = 0 To UBound(b)
lh = b(s)
If ar(i, lh) <> "" Then
mc = ar(1, lh) & " " & zd
sh.Copy
Set wb = ActiveWorkbook
With wb.Sheets(1)
.Name = "检验报告"
.[b4] = ar(i, 6)
.[f4] = ar(i, 3)
.[b5] = ar(i, 5)
.[f5] = ar(i, 4)
.[b6] = ar(i, 7)
.[f6] = ar(i, 2)
End With
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & mc & ".xlsx"
wb.Close
End If
Next s
End If
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|