有偿！可以将这个表格每两行导出为图片另存吗！

lj1226189

2022(2).zip (484.14 KB, 下载次数: 21)

2024-12-14 06:43 上传

点击文件名下载附件

每两行一个图片导出时命名一个文件文件夹为客户名，将图片导入到这个文件夹 图片也命名为客户名 最终所有和文件夹都在一个大文件夹内！

谢谢！
可以加微
18905112810

shiruiqiang

虽然简单的，给别的老师搞了。
论坛可用代码一大把

约定的童话

Sub VBA截图并导出图片()
    Application.ScreenUpdating = False
    Dim Newshape As Shape, rng As Range, shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
    Next
    If Dir(ThisWorkbook.Path & "\图片", vbDirectory) = "" Then MkDir ThisWorkbook.Path & "\图片"
    For i = 2 To [a65536].End(3).Row
        If Cells(i, 2) <> "" Then
            Cells(i, 2).Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            ActiveSheet.Paste
            For Each shp In ActiveSheet.Shapes
                If shp.Type = msoPicture Then
                    Set rng = shp.BottomRightCell
                    shp.Copy
                    With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
                        .Parent.Select
                        .Paste
                        .Export ThisWorkbook.Path & "\图片\" & Cells(i, 1) & ".jpg"
                        .Parent.Delete
                    End With
                End If
            Next
            For Each shp In ActiveSheet.Shapes
                If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
            Next
        End If
    Next
    [a1].Select
    MsgBox "导出完毕！", 64, "提示！"
End Sub

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, strFileName As String, strPath$, strSavePath$, dWidth$, dHeight$
   
    strPath = ThisWorkbook.Path & "\生成图片文件夹\"
    If Dir(strPath, vbDirectory) = "" Then MkDir strPath
   
    With Worksheets(1)
        With .[A1].CurrentRegion
            ar = .Value
            For i = 1 To 10 Step 2
                strSavePath = strPath & ar(i + 1, 3) & "\"
                If Dir(strSavePath) = "" Then MkDir strSavePath
                strFileName = strSavePath & ar(i + 1, 3) & ".jpg"
                With .Cells(i, 1).Resize(2, UBound(ar, 2))
                    dWidth = .Width: dHeight = .Height
                    .CopyPicture xlScreen, xlPicture
                End With
                With .Parent.ChartObjects.Add(0, 0, dWidth, dHeight)
                    With .Chart
                        .Parent.Select
                        .Paste
                        .ChartArea.Format.Line.Visible = msoFalse
                        .PlotArea.Format.Line.Visible = msoFalse
                        .ChartArea.Fill.Visible = msoFalse
                        .PlotArea.Fill.Visible = msoFalse
                        .Export Filename:=strFileName
                    End With
                    .Delete
                End With
            Next i
        End With
    End With
   
    Beep
End Sub

gwjkkkkk

请参考。。。

HANERBABA

学习学习