导出的图片为何多了白区

zzpsx

导出的图片为何多了白区.rar (72.46 KB, 下载次数: 2)

2023-1-31 16:22 上传

点击文件名下载附件

运行代码，可以导出为图片。在excel 2016中正常。
但在excel 2021版本中，多了白区，请问如何解决？

代码如下

Sub excel转ppt()
'16号字体
Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim rn As Range
    j = 1
    Set sht = ActiveSheet
    r = sht.Range("B65536").End(xlUp).Row
    Rem 公式转为数值
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
   
    sht.Columns("A:A").Insert Shift:=xlToRight
    For Each rn In sht.Range("A1:A" & r)
        i = rn.Row
        If i Mod 7 = 0 Then
            sht.Cells(i, 1).Offset(-6, 0).Resize(7, 1) = j
            j = j + 1
        End If
    Next
    For Each rn In sht.Range("A1:A" & r)
        If rn = "" Then rn = j
    Next
    sht.Rows(1).Insert
    cosplit = Asc("A") - 64
    rownumber = 2
    coendrow = 2
    coendcol = Asc("C") - 64
    Dim d, arr, brr, crr
    Set d = CreateObject("Scripting.Dictionary")
    s = sht.Cells(65536, coendcol).End(xlUp).Row
    coall = sht.Cells(coendrow, 256).End(xlToLeft).Column
    arr = sht.Range(sht.Cells(rownumber - 1, 1), sht.Cells(s, coall))
    Set oRng = sht.Range("A" & rownumber - 1).Resize(1, UBound(arr, 2))
    ReDim crr(2 To UBound(arr))
    For i = 2 To UBound(arr)
        crr(i) = arr(i, cosplit)
    Next
    For i = 2 To UBound(arr)
        d(crr(i)) = ""
    Next
    For Each k In d.keys
        Sheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            oRng.Copy .Cells(1, 1)
            m = 2
            For i = 2 To UBound(arr)
                If arr(i, cosplit) = k Then
                    sht.Range(sht.Cells(i + rownumber - 2, 1), sht.Cells(i + rownumber - 2, coall)).Copy .Cells(m, 1)
                    m = m + 1
                End If
            Next
            sht.Range(sht.Cells(1, 1), sht.Cells(1, coall)).Copy '可酌情加上
            .Cells(1, 1).PasteSpecial (xlPasteColumnWidths) '可酌情加上
            
            .UsedRange.Borders.LineStyle = xlContinuous
            .UsedRange.Borders.Weight = xlHairline 'xlThin
            .UsedRange.Borders.Color = RGB(87, 134, 55)
            .UsedRange.RowHeight = 26 '行高
            .PageSetup.Zoom = False
            .PageSetup.FitToPagesWide = 1
            .PageSetup.CenterHorizontally = True '水平居中
            .Rows(1).Delete
            .Columns(1).Delete
            Rem 隔行着色
            For i = 1 To .Range("B65536").End(xlUp).Row Step 2
                .Range("A" & i & ":e" & i).Interior.Color = RGB(226, 239, 218)
            Next
            Rem 自动序号
            '.Range("A1").Formula = "=ROW()"
            'rn3 = .Range("B" & .Rows.Count).End(xlUp).Row
            'Set oRng = .Range(.Cells(1, "A"), .Cells(rn3, "A"))
            '.Cells(1, "A").AutoFill oRng
            
            .Cells(1, 1).Select
            'If Wb.Sheets.Count = 1 Then .Name = k Else .Name = sht.Name & "_" & k
            .Name = Format(k, "00")
            '.Range("A2").EntireRow.Insert
            '.Range("A2") = "合计"
            '.Range("D2").Formula = "=sum(D3:D65536)"
        End With
        m = 0
    Next
    d.RemoveAll
   
    Sheets(1).Activate
    Sheets(1).Columns("A:A").Delete
    Sheets(1).Rows(1).Delete
    Dim ws As Worksheet
    Dim path As String
    Dim rng As Range
    path = ActiveWorkbook.path & "\export_jpg"
    If Dir(path, vbDirectory) = vbNullString Then MkDir path
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            Set rng = ws.Range("A1").CurrentRegion
            rng.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
            With ws.ChartObjects.Add(0, 0, rng.Width * 3, rng.Height * 3).Chart
                .Parent.Select
                .Paste
                .Export path & "\" & ws.Name & ".jpg"
                .Parent.Delete
            End With
            Set rng = Nothing
        End If
    Next
    Rem 删除不用表格
    Application.DisplayAlerts = False
    Sheets(Array("Sheet1")).Select
    Dim drr
    ReDim drr(1 To Sheets.Count)
    For Each sh In ActiveWindow.SelectedSheets
        m = m + 1
        drr(m) = sh.Name
    Next
    m = 0
    For Each sh In Sheets
        For a = 1 To UBound(drr)
            If sh.Name = drr(a) Then
                mark = drr(a)
                GoTo 100:
            End If
        Next a
        sh.Delete
100:
    Next
    Sheets(mark).Select
    Application.DisplayAlerts = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub