excel提取图片请教

qianbing

测试表.rar (111.32 KB, 下载次数: 3)

2023-4-27 15:52 上传

点击文件名下载附件

一个EXCEL2007工作簿，其中有sheet1及sheet2两张表，sheet1有数据，sheet2为空白表，sheet1中每1行是1条记录，第7列的单元格中为每条记录的图片，图片是嵌入单元格的；第5列为每条记录的内容描述； 第6列为每条记录的地点描述。现在需要提取sheet1中的记录写入本工作簿中的另外一张表格sheet2，提取要求为： sheet2第1列的第1至3行分别放入sheet1中第1条记录的图片、内容描述、地点描述；sheet2第2列的1至3行分别放入sheet1中第2条记录的图片、内容描述、地点描述；sheet2第1列的4至6行分别放入sheet1表中第3条记录的图片、内容描述、地点描述；sheet2第2列的4至6行分别放入sheet1中第4条记录的图片、内容描述、地点描述，如此循环直到sheet1中的最后1条记录

这是代码，附件已经加入代码，
但是没能提取到图片，求修正代码：

Sub ExtractRecords()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim i As Long
Dim j As Long

Set wsSource = ThisWorkbook.Sheets("sheet1")
Set wsTarget = ThisWorkbook.Sheets("sheet2")

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

j = 1 '计数器，用于控制写入新表格的行数

For i = 1 To lastRow Step 2 '每次循环提取两条记录，因为每个记录占据两行

'写入第一列
wsSource.Range("G" & i).Copy '复制图片
wsTarget.Cells(j, 1).PasteSpecial '粘贴图片
wsTarget.Cells(j + 1, 1).Value = wsSource.Cells(i, 5).Value '内容描述
wsTarget.Cells(j + 2, 1).Value = wsSource.Cells(i, 6).Value '地点描述

'写入第二列
wsSource.Range("G" & i + 1).Copy '复制图片
wsTarget.Cells(j, 2).PasteSpecial '粘贴图片
wsTarget.Cells(j + 1, 2).Value = wsSource.Cells(i + 1, 5).Value '内容描述
wsTarget.Cells(j + 2, 2).Value = wsSource.Cells(i + 1, 6).Value '地点描述

j = j + 3 '每次循环后计数器加3，因为每条记录占据3行
Next i
End Sub