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

阿哩木

313667354 发表于 2025-3-31 17:03
要把数据一段段做成图片，这样做的目的是做什么用途呢？

自然是工作上需要了

阿哩木

lss001 发表于 2025-3-31 15:56
请参考一下附件代码！

大佬大佬 ！！就是你做的这个结果，但还是有点点地方需要修改一下 可以留下QQ吗 我在上面再请教您下 这个忙必须给您点辛苦费，一点小心意！！

lss001

阿哩木 发表于 2025-3-31 19:25
大佬大佬 ！！就是你做的这个结果，但还是有点点地方需要修改一下 可以留下QQ吗 我在上面再请教您下 这个 ...

有什么问题在论坛也可以发私信

Enocheasty

我也用AI写了一个，改了改，可以用

1. Sub ExportDataToImages()
   
2.     Dim ws As Worksheet
   
3.     Dim lastRow As Long, currentRow As Long
   
4.     Dim batchStart As Long, batchEnd As Long
   
5.    
   
6.     Set ws = ThisWorkbook.ActiveSheet
   
7.     lastRow = ws.UsedRange.Rows.Count
   
8.     currentRow = 3 ' 数据起始行
   
9.    
   
10.     Application.ScreenUpdating = False
    
11.     Application.DisplayAlerts = False
    
12.     Do While currentRow <= lastRow
    
13.         batchStart = currentRow
    
14.         batchEnd = FindBatchEnd(ws, batchStart, lastRow)
    
15.         ProcessABatch ws, batchStart, batchEnd
    
16.         currentRow = batchEnd + 1
    
17.     Loop
    
18.    
    
19.     ws.Rows.EntireRow.Hidden = False
    
20.     Application.ScreenUpdating = True
    
21.     Application.DisplayAlerts = True
    
22. 
    
23.     MsgBox "处理完成！"
    
24. End Sub
    
25. 
    
26. Function FindBatchEnd(ws As Worksheet, startRow As Long, lastRow As Long) As Long
    
27.     Dim currentValue As String
    
28.     currentValue = ws.Cells(startRow, "B").Value
    
29.     FindBatchEnd = startRow
    
30.    
    
31.     Do While FindBatchEnd < lastRow
    
32.         Dim nextRow As Long
    
33.         nextRow = FindBatchEnd + 1
    
34.         
    
35.         If ws.Cells(nextRow, "B").Value = currentValue Or ws.Cells(nextRow, "B").Value = "HJ" Then
    
36.             FindBatchEnd = nextRow
    
37.         Else
    
38.             Exit Do
    
39.         End If
    
40.     Loop
    
41. End Function
    
42. 
    
43. Sub ProcessABatch(ws As Worksheet, batchStart As Long, batchEnd As Long)
    
44.     Dim subStart As Long, subEnd As Long
    
45.     Dim outputRange As Range
    
46.    
    
47.     subStart = batchStart
    
48.    
    
49.     Do While subStart <= batchEnd
    
50.         subEnd = FindSubEnd(ws, subStart, batchEnd)
    
51.         subEnd = CheckHJSpecial(ws, subEnd, batchEnd)
    
52.         
    
53.         On Error Resume Next
    
54.         Set outputRange = ws.Range(ws.Cells(1, "A"), ws.Cells(subEnd, "N"))
    
55.         
    
56.         If Not outputRange Is Nothing Then
    
57.             ExportAsImage ws, outputRange, "Export_" & subStart & "_" & subEnd
    
58.         Else
    
59.             MsgBox "无法合并范围：行" & subStart & "-" & subEnd
    
60.         End If
    
61.         ws.Rows(CLng(subStart) & ":" & CLng(subEnd)).Select
    
62.         Selection.EntireRow.Hidden = True
    
63.         subStart = subEnd + 1
    
64.     Loop
    
65. End Sub
    
66. 
    
67. Function FindSubEnd(ws As Worksheet, startRow As Long, batchEnd As Long) As Long
    
68.     FindSubEnd = startRow
    
69.     If startRow >= batchEnd Then Exit Function
    
70.    
    
71.     Do While FindSubEnd < batchEnd
    
72.         Dim nextRow As Long
    
73.         nextRow = FindSubEnd + 1
    
74.         
    
75.         If ws.Cells(nextRow, "A").Value = 1 Then
    
76.             Exit Do
    
77.         Else
    
78.             FindSubEnd = nextRow
    
79.         End If
    
80.     Loop
    
81. End Function
    
82. 
    
83. Function CheckHJSpecial(ws As Worksheet, currentEnd As Long, batchEnd As Long) As Long
    
84.     CheckHJSpecial = currentEnd
    
85.     If currentEnd >= batchEnd Then Exit Function
    
86.    
    
87.     Dim i As Long
    
88.     For i = currentEnd + 1 To batchEnd
    
89.         If IsEmpty(ws.Cells(i, "A")) And ws.Cells(i, "B").Value = "HJ" Then
    
90.             CheckHJSpecial = i
    
91.         Else
    
92.             Exit For
    
93.         End If
    
94.     Next i
    
95. End Function
    
96. 
    
97. Sub ExportAsImage(ws As Worksheet, rng As Range, filename As String)
    
98.     If ws Is Nothing Then
    
99.         MsgBox "工作表对象无效！"
    
100.         Exit Sub
     
101.     End If
     
102.    
     
103.     If rng Is Nothing Then
     
104.         MsgBox "输出范围无效！"
     
105.         Exit Sub
     
106.     End If
     
107.    
     
108.     Dim chartObj As ChartObject
     
109.     Dim tempChart As Chart
     
110.    
     
111.     ' 复制为图片
     
112.     rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
     
113.    
     
114.     ' 创建临时图表对象
     
115.     Workbooks.Add
     
116.     ActiveSheet.Paste
     
117.     Set shp = ActiveSheet.Shapes(1)
     
118.         With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
     
119.                 .Parent.Select
     
120.                 .Paste
     
121.                 .Export ws.Parent.Path & "" & filename & ".png"
     
122.         End With
     
123.     ' 清理对象
     
124.    ActiveWorkbook.Close False
     
125. End Sub
     

复制代码

表格内容保存为图片.zip (273.98 KB, 下载次数: 8)

2025-3-31 21:46 上传

点击文件名下载附件

翁知江安

Sub test()
Dim i, m, k, n, irow As Integer
Dim ar As Variant
Dim ws As Worksheet
Dim rng As Range
Dim zoom#
zoom = 2
Dim Chartobj As ChartObject
Dim p As String
p = ThisWorkbook.Path & "\"
ThisWorkbook.Sheets("a").Activate
Set ws = ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
ws.Name = "过渡"
ar = ThisWorkbook.Sheets("A").Range("a1:o" & Sheets("A").[b65536].End(xlUp).Row + 1)
ar(UBound(ar), 2) = "HJ"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 3 To UBound(ar)
  With ThisWorkbook.Sheets("过渡")
  If ar(i, 2) <> "HJ" Then
    If InStr(ar(i, 1), 1) > 0 Then
      m = m + 1
      ThisWorkbook.Sheets("a").Cells(i, UBound(ar, 2)) = m
        If .[a1] = "" Then
            ThisWorkbook.Sheets("A").Range("a1:n2").Copy
            .[a1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            .[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Else
            irow = .[a65536].End(xlUp).Row
            ThisWorkbook.Sheets("A").Range("a1:n2").Copy
            .Cells(irow + 2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            .Cells(irow + 2, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
         End If
      irow = .[a65536].End(xlUp).Row
      ThisWorkbook.Sheets("a").Cells(i, 1).Resize(1, UBound(ar, 2)).Copy
      .Cells(irow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      .Cells(irow + 1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Application.CutCopyMode = False
     End If
  End If
  End With
  If ar(i, 2) = "HJ" Then
    ThisWorkbook.Sheets("过渡").Columns.AutoFit
    n = n + 1
    Set rng = ThisWorkbook.Sheets("过渡").UsedRange
    rng.CopyPicture xlPrinter, xlPicture
    With ThisWorkbook.Sheets("过渡").ChartObjects.Add(0, 0, rng.Width * zoom, rng.Height * zoom).Chart
         .Parent.Select
         .Paste
         .Export p & "图片" & n & ".png", "png"
         .Parent.Delete
    End With
    ThisWorkbook.Sheets("过渡").Activate
    ThisWorkbook.Sheets("过渡").[a1].Resize(100, UBound(ar, 2)).Clear
  End If
Next
Application.CutCopyMode = False
ThisWorkbook.Sheets("过渡").Delete
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正。存在的缺点：运行速度有点慢

翁知江安

这是用时情况，供参考。

chl0924

稳定度不佳。
有时后，输出的图片，最前面几张，会只有 1 KB ，而图片是空白的。
有时后，paste 会产生错误，而需要 resume 。
为了仅量不出现上面状况，在效率上，也不好。
还是，就不要为难Excel了。

1. Sub Main()
   
2.     Dim PNG_Path As String
   
3.     PNG_Path = ThisWorkbook.Path
   
4.    
   
5.     Main_sb "A", PNG_Path
   
6.    
   
7.     Main_sb "B", PNG_Path
   
8. End Sub
   
9. 
   
10. Sub Main_sb(wsName As String, PNG_Path As String)
    
11.     Application.ScreenUpdating = False
    
12.    
    
13.     sbSheet_tmp wsName
    
14.    
    
15.     sbCopyToPic wsName
    
16.    
    
17.     sbPNG_Fill_ForeColor
    
18.    
    
19.     sbExport_PNG wsName, PNG_Path
    
20. End Sub
    
21. 
    
22. Sub sbSheet_tmp(wsName As String)
    
23.     Dim wsTemp As Worksheet
    
24.     Set wsTemp = Sheets.Add
    
25.     wsTemp.Name = "Temp"
    
26.    
    
27.     Dim ws As Worksheet
    
28.     Set ws = Worksheets(wsName)
    
29.     nCols = ws.Range("A1").CurrentRegion.Columns.Count
    
30.    
    
31.     ws.Columns("A").Resize(, nCols).Copy
    
32.    
    
33.     wsTemp.Range("A1").PasteSpecial
    
34.     wsTemp.Range("A1").CurrentRegion.Offset(2).Clear
    
35. End Sub
    
36. 
    
37. Sub sbCopyToPic(wsName As String)
    
38.     Dim ws As Worksheet
    
39.     Set ws = Worksheets(wsName)
    
40.     ws.Activate
    
41.     nRows = ws.Range("A1").CurrentRegion.Rows.Count
    
42.     nCols = ws.Range("A1").CurrentRegion.Columns.Count
    
43.    
    
44.     Dim wsTemp As Worksheet
    
45.     Set wsTemp = Worksheets("Temp")
    
46.    
    
47.     Dim Row_Start
    
48.     Dim Row_End
    
49.     For i = 1 To nRows - 1
    
50.         If Range("A1").Offset(i) = 1 Then
    
51.             If Row_Start = "" Then
    
52.                 Row_Start = i
    
53.             Else
    
54.                 Row_End = i - 1
    
55.             End If
    
56.         End If
    
57.         
    
58.         If i = nRows - 1 Then
    
59.             Row_End = i
    
60.         End If
    
61.         
    
62.         If Range("A1").Offset(i) = "" And Range("B1").Offset(i) = "" Then
    
63.             Row_End = i - 1
    
64.             myExit_for = True
    
65.         End If
    
66.         
    
67.         If Row_Start <> "" And Row_End <> "" Then
    
68.             wsTemp.Range("A1").CurrentRegion.Offset(2).Clear
    
69.             Range(Range("A1").Offset(Row_Start), Cells(Row_End + 1, nCols)).Copy
    
70.             wsTemp.Range("A3").PasteSpecial
    
71.             wsTemp.Range("A1").CurrentRegion.CopyPicture xlScreen, xlPicture
    
72.             wsTemp.Cells(1, nCols + 2).PasteSpecial
    
73.             i = i - 1
    
74.             Row_Start = ""
    
75.             Row_End = ""
    
76.         End If
    
77.         
    
78.         If myExit_for Then Exit For
    
79.     Next i
    
80. End Sub
    
81. 
    
82. Sub sbPNG_Fill_ForeColor()
    
83.     Worksheets("Temp").Activate
    
84.     Worksheets("Temp").Shapes.SelectAll
    
85.     Selection.ShapeRange.Fill.Visible = msoTrue
    
86.     Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
    
87. End Sub
    
88. 
    
89. Sub sbExport_PNG(wsName As String, PNG_Path As String)
    
90.     Application.ScreenUpdating = True
    
91.     Dim ws As Worksheet
    
92.     Set ws = Worksheets("Temp")
    
93.     ws.Activate
    
94.    
    
95.     Dim nShapes
    
96.     nShapes = ws.Shapes.Count
    
97.    
    
98.     Dim chartObj As ChartObject
    
99.     Set chartObj = ws.ChartObjects.Add(Left:=20, Top:=20, Width:=100, Height:=100)
    
100.    
     
101.     Dim x As Shape
     
102.     For Each x In ws.Shapes
     
103.         i = i + 1
     
104.         DoEvents
     
105.         x.Copy
     
106.         With chartObj
     
107.             .Width = x.Width
     
108.             .Height = x.Height
     
109.             With .Chart
     
110.             .Paste
     
111.             .Export fileName:=PNG_Path & "" & wsName & "_PNG_" & i & ".png"
     
112.             End With
     
113.         End With
     
114.         If i = nShapes Then Exit For
     
115.     Next x
     
116.    
     
117.     Application.DisplayAlerts = False
     
118.     ws.Delete
     
119. End Sub

复制代码

micch

这是一个保准的求助，建议更多的人看到，参考学习。 有举例的数据，并且也有代表性，包含了自己需要的几个情况，并且有手动整理数据的结果，和模拟了需要生成的结果。然后搭配文字描述具体的规则和要求，而且描述也很有条理性，基本完整的阐述了需求，让人看看一遍基本就懂了。

micch

1. Sub Main()
   
2.     '需求是生成图片，但是数据和标题不挨着，肯定没法直接生成图片，需要一个辅助区域
   
3.     '既然标题固定都有，那么先准备一个辅助的标题，可以手工去做一个模板
   
4.     On Error GoTo ErrLine
   
5.     Dim sh As Worksheet, coll As Collection
   
6.     Dim fdPth As String, ar
   
7.    
   
8.     '1
   
9.     Set sh = SetSheetTitle                  '建临时表用来导出图片
   
10. '    Set sh = Sheets("A表备份")             '其实可以手动建个表，格式自己设置好更方便
    
11.    
    
12.     '2  数据源整理拆分成独立的数据，用数组存储
    
13.     Set coll = GetCleanData(Sheet2)
    
14.    
    
15.     '3  循环导出图片
    
16.     AppSet False
    
17.     fdPth = ".....\AA"
    
18.     For Each ar In coll
    
19.         k = k + 1
    
20.         With sh
    
21.             .Range("A3:N" & UBound(ar) + 2).Value = ar
    
22.             Call ExportPng(.Range("A1:N" & UBound(ar) + 2), fdPth & "图片" & k)
    
23.             .Range("A3:N" & UBound(ar) + 2).ClearContents
    
24.         End With
    
25.     Next
    
26. ErrLine:
    
27. '    sh.Delete '临时表用完销毁
    
28.     AppSet True
    
29. End Sub
    
30. Function SetSheetTitle() As Worksheet
    
31.     Sheets("A").Copy Before:=Sheets(1)
    
32.     With ActiveSheet
    
33.         .Range("P:az").Clear
    
34.         .Rows("3:9999").ClearContents
    
35.     End With
    
36.     Set SetSheetTitle = ActiveSheet
    
37. End Function
    
38. Function GetCleanData(sh As Worksheet) As Collection
    
39.     With sh
    
40.         r = .Cells(.Rows.Count, 2).End(3).Row
    
41.         ar = .Range("A1:N" & r + 1).Value
    
42.     End With
    
43.     Dim cl As New Collection
    
44.     r1 = 3
    
45.     For j = 3 To r
    
46.         If j = r Or ar(j + 1, 1) = 1 Then
    
47.             n = j - r1 + 1
    
48.             ReDim br(1 To n, 1 To 14)
    
49.             For i = 1 To n
    
50.             For k = 1 To 14
    
51.                 br(i, k) = ar(r1 + i - 1, k)
    
52.             Next
    
53.             Next
    
54.             cl.Add br, "图片" & cl.Count + 1
    
55.             r1 = j + 1
    
56.         End If
    
57.     Next
    
58.     Set GetCleanData = cl
    
59. End Function
    
60. Function ExportPng(rng0 As Range, PicPth As String) '导出图片懒得写了，论坛很多单元格区域导出图片的代码
    
61.     r = rng0.Offset(65000, 18).End(3).Offset(2).Row
    
62.     rng0.Worksheet.Cells(r, "R").Value = PicPth
    
63.     rng0.Copy rng0.Worksheet.Cells(r + 1, "R")        '复制成独立的区域为例演示结果
    
64. End Function
    
65. Public Sub AppSet(AppBl As Boolean)
    
66.     With Application
    
67.         .ScreenUpdating = AppBl
    
68.         .DisplayAlerts = AppBl
    
69.         .EnableEvents = AppBl
    
70.     End With
    
71. End Sub
    

复制代码