表格内容保存为图片，在此跪求大神、巨佬来帮忙解决下这个问题！

阿哩木

chl0924 发表于 2025-4-1 01:55
稳定度不佳。
有时后，输出的图片，最前面几张，会只有 1 KB ，而图片是空白的。
有时后，paste 会产生错 ...

楼上lss001大哥帮我完美解决了  也感谢您的帮忙！！

阿哩木

micch 发表于 2025-4-1 10:15

代码已收藏，在下会多研究学习，感谢老师！！

阿哩木

Enocheasty 发表于 2025-3-31 21:47
我也用AI写了一个，改了改，可以用

昂？您用的是哪个AI，deepseek都被我问懵逼了，结果完全不对

阿哩木

在此分享下lss001老师帮忙写的代码
希望能对有需要的人有帮助

Sub png格式()
    Dim sht As Worksheet, rng As Range
    Dim i&, j&, m&, n&, n1&, n2&, brr(), arr, x&

    Set sht = ActiveSheet                   '当前表
    r = Cells(Rows.Count, 2).End(3).Row     '结束行
    sht.Cells.EntireRow.Hidden = False      '取消隐藏
    Application.Windows(1).ScrollRow = 3    '滚动窗口置顶
    With sht.Cells.CurrentRegion            '当前区域
        c = .Cells(2, .Columns.Count).End(4).Column - 1  '结束列
        arr = .Range(.Cells(3, 1), .Cells(r, c))         '区域数组
        x = WorksheetFunction.CountIf(Range("A1:A" & r), 1)    '总页数
    End With

    ReDim brr(1 To x, 1): n = 1
    For i = 1 To x
        m = 0
        For j = n To r - 2
            If m > 0 And j <= r - 2 Then  '***
                If arr(j, 1) = 1 Then
                    n2 = j - 1: Exit For  '结束1
                ElseIf arr(j, 1) = "" Then
                    If arr(j, 2) <> "" Then
                        n1 = j: Exit For  '结束2
                    End If
                End If
            Else: n1 = j  '*****
            End If
            If arr(j, 1) = 1 Then m = j
        Next
        If n1 > n2 Then n = n1 Else n = n2
        brr(i, 0) = m + 2  '区域开始位置
        brr(i, 1) = n + 2  '区域结束位置
        If n1 > n2 Then n = n1 Else n = n2 + 1
    Next

    For i = 1 To UBound(brr)
        If i > 1 Then
            Set rng = sht.Range(sht.Cells(3, c), sht.Cells(brr(i - 1, 1), c))
            rng.EntireRow.Hidden = True  '隐藏区域
        End If
        sht.Range(sht.Cells(1, 1), sht.Cells(brr(i, 1), c)).CopyPicture 1, 2          '复制区域
        With sht.ChartObjects.Add(0, 0, 800, 28 * (brr(i, 1) - brr(i, 0) + 3)).Chart  '添加图表
            .Parent.Select      '选择图表
            .Paste              '粘贴区域
            .Export "C:\Users\Administrator\Desktop\AA\" & i & ".png"  '导出图片
            .Parent.Delete      '删除图表
        End With
    Next

    sht.Cells.EntireRow.Hidden = False      '取消隐藏
    Application.Windows(1).ScrollRow = 3    '滚动窗口置顶
    Set sht = Nothing    '释放对象
    Set rng = Nothing
End Sub

Enocheasty

阿哩木 发表于 2025-4-1 20:39
昂？您用的是哪个AI，deepseek都被我问懵逼了，结果完全不对

我就是用的DeepSeek，主要是我觉得你的表述可能不太利于AI理解。我给它的表述是：
有个Excel表格，现在需要将A~N列输出为图片，输出规格如下：1、第1、2行为表头，每个输出的图片内都要包含；2、从第3行开始为数据，根据表头B列内容进行条件识别，并确定输出的具体行数；3、如果B列的内容与下一行B列相同，则作为一批，直至下一行内容发生变化或者为“HJ”，如果为HJ，则将HJ这行也算在此批，否则为不同批；4、当同一批，A列的序号作为进一步细分输出的依据，如A列内容为1，下行A列依然为1，表示下从新作为一批输出，否则，按同一批输出，直到下行内容从新开始于1。同时，如果检查到A列为空且对应的B列值为“HJ”,则将此行与当前批一并输出。以上请用VBA程序写出。
输出的程序基本没太大问题，主要有2个问题，一个是输出图片子程序它使用的方式有问题，另一个就是当表头和输出数据内容分开的时候，输出会失败，因为选择区域为多个子区域，此时不支持CopyPicture方法，我稍微调整了一下。中间非筛选数据也包含在选择范围，不过隐藏中间行再输出，就没问题了。