怎么批量生成含图片的标准打印格式

cqzcwboy

现在需要打印一批资料，图片全部在文件夹内，另外每张图片对应该的文字说明。怎么通过EXCEL批量生成统一的打印格式文件。可以用文件名取图片，目前我正在学习VBA，知道应该是可以，但不会。请大神帮帮忙，我附上表格，里面有资料的最终想要的结果样子

下面图片是想要打印样子，每页生成出来就是这样子。第5张到第8页生成到下一页打印，谢谢拉。

daibao88

既然懂vba，就翻前边的帖子，例子很多

cqzcwboy

daibao88 发表于 2018-7-4 20:12
既然懂vba，就翻前边的帖子，例子很多

才开始学，目前还不会写，我正在论坛里找没看到有类似的

daibao88

cqzcwboy 发表于 2018-7-4 20:25
才开始学，目前还不会写，我正在论坛里找没看到有类似的

论坛里 单元格插入图片的例子，比牛毛都多，稍微已改就行

cqzcwboy

daibao88 发表于 2018-7-4 21:07
论坛里 单元格插入图片的例子，比牛毛都多，稍微已改就行

VBA插入图片我会了，但生成固定格式，还自动往下换页自动调格式暂时还不会

yuygog

Sub ×îÖÕDèÇó½á1û()  '

On Error Resume Next


Worksheets("×îÖÕDèÇó½á1û").Activate


Application.ScreenUpdating = False

Cells.Clear


Cells.NumberFormatLocal = "@"

Rows.Font.Name = "Î￠èíÑÅoú"


Cells.HorizontalAlignment = xlCenter ''×óóò¾óÖD
        Cells.VerticalAlignment = xlCenter ''éÏϾóÖD



Dim rng As Range



Dim shp As Shape

For Each shp In ActiveSheet.Shapes
shp.Delete

Next



Dim maxrow%, maxcol%, arr


With Worksheets("′îÅäÃ÷ϸ±í")

maxrow = .Cells(Rows.Count, "A").End(xlUp).Row

maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column

arr = .Range(.[A2], .Cells(maxrow, maxcol))

End With






Dim item%, i2%

i2 = 1




For i = 1 To UBound(arr)


item = item + 1


Cells(i2, item).Value = arr(i, 1)

Cells(i2, item).RowHeight = 19.5

Cells(i2, item).ColumnWidth = 28

Cells(i2 + 1, item).RowHeight = 367.5




Cells(i2 + 2, item).RowHeight = 142


Cells(i2 + 3, item).RowHeight = 1


Rows(i2).Font.Bold = True





Set rng = Cells(i2 + 1, item)


ActiveSheet.Shapes.AddPicture arr(i, 9), msoTrue, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height



Cells(i2 + 2, item).WrapText = True

Cells(i2 + 2, item) = arr(i, 8)




If item = 4 Then


item = 0

i2 = i2 + 4

End If


Next



Application.ScreenUpdating = True





End Sub

yuygog

Sub 最终需求结果()  '

On Error Resume Next


Worksheets("最终需求结果").Activate


Application.ScreenUpdating = False

Cells.Clear


Cells.NumberFormatLocal = "@"

Rows.Font.Name = "微软雅黑"


Cells.HorizontalAlignment = xlCenter ''左右居中
        Cells.VerticalAlignment = xlCenter ''上下居中



Dim rng As Range



Dim shp As Shape

For Each shp In ActiveSheet.Shapes
shp.Delete

Next



Dim maxrow%, maxcol%, arr


With Worksheets("搭配明细表")

maxrow = .Cells(Rows.Count, "A").End(xlUp).Row

maxcol = .Cells(1, Columns.Count).End(xlToLeft).Column

arr = .Range(.[A2], .Cells(maxrow, maxcol))

End With






Dim item%, i2%

i2 = 1




For i = 1 To UBound(arr)


item = item + 1


Cells(i2, item).Value = arr(i, 1)

Cells(i2, item).RowHeight = 19.5

Cells(i2, item).ColumnWidth = 28

Cells(i2 + 1, item).RowHeight = 367.5




Cells(i2 + 2, item).RowHeight = 142


Cells(i2 + 3, item).RowHeight = 1


Rows(i2).Font.Bold = True





Set rng = Cells(i2 + 1, item)


ActiveSheet.Shapes.AddPicture arr(i, 9), msoTrue, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height



Cells(i2 + 2, item).WrapText = True

Cells(i2 + 2, item) = arr(i, 8)




If item = 4 Then


item = 0

i2 = i2 + 4

End If


Next



Application.ScreenUpdating = True





End Sub

cqzcwboy

yuygog 发表于 2018-7-5 19:32
Sub 最终需求结果()  '

On Error Resume Next

这个代码我研究了下，行高之类的我有调整，能用。
再请教一个问题，现在图片是填充满单元格。图片高度以单元格高度填充（没问题），
我想宽度不以填充满单元格为标准，只填满高度，宽度根据图片自动调，不知怎么改代码？  这样可以保持图片的比例

cqzcwboy

yuygog 发表于 2018-7-5 19:32
Sub 最终需求结果()  '

On Error Resume Next

意思就是保持原图片的比例显示

yuygog

ActiveSheet.Shapes.AddPicture arr(i, 9), msoTrue, msoCTrue, rng.Left, rng.Top, rng.Width, rng.Height

替换为：

With ActiveSheet.Pictures.Insert(arr(i, 9))

.Top = rng.Top
.Height = rng.Height
.Left = rng.Left
.ShapeRange.lockAspectration = msoTrue
.Left = (rng.Width - .Width) / 2 + rng.Left
.Top = (rng.Height - .Height) / 2 + rng.Top

End With