[已解决]大虾们，能帮忙“打磨”一下这个代码吗？先谢过了 ——应该是最后一步

白云无尽9987

n n.rar (17.7 KB, 下载次数: 15)

2015-5-24 22:46 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2015-5-25 08:25

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:b5")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     For I = 10 To 15
   
8.         Range("A7") = Cells(I, 2)
   
9.         Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
10.         ActiveSheet.Pictures.Paste.Select
    
11.         With Selection
    
12.             .Copy
    
13.             With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
14.                 .Paste
    
15.                 .Export Desktop & "" & Range("A1") & ".jpg"
    
16.                 .Parent.Delete
    
17.             End With
    
18.             .Delete
    
19.         End With
    
20.         Application.Wait (Now + TimeValue("0:00:01"))
    
21.     Next
    
22. End Sub

复制代码

跳转到最佳答案楼层

zjdh

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:b5")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     For I = 10 To 15
   
8.         Range("A7") = Cells(I, 2)
   
9.         Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
10.         ActiveSheet.Pictures.Paste.Select
    
11.         With Selection
    
12.             .Copy
    
13.             With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
14.                 .Paste
    
15.                 .Export Desktop & "" & Range("A1") & ".jpg"
    
16.                 .Parent.Delete
    
17.             End With
    
18.             .Delete
    
19.         End With
    
20.         Application.Wait (Now + TimeValue("0:00:01"))
    
21.     Next
    
22. End Sub

复制代码

白云无尽9987

zjdh 发表于 2015-5-25 08:25

五体投地！！！！！我只是敢想想而已，还真能做到啊！不敢相信！！教授就是教授，德艺双馨！！赞

白云无尽9987

zjdh 发表于 2015-5-25 08:25

针对这个问题再次深入请教一下高手您：如果桌面上已经新建了一个名为m的文件夹，怎样把这些代码生成的图片保存在“桌面/m”里，而不仅是“桌面”？

zjdh

1. Sub main()
   
2.     Dim Rng As Range, Desktop As String
   
3.     If TypeName(Selection) <> "Range" Then MsgBox "必须选择单元格！", , "提示": Exit Sub
   
4.     If Selection.Areas.Count > 1 Then MsgBox "只能选择一个区域！", , "提示": Exit Sub
   
5.     Set Rng = Range("A2:b5")
   
6.     Desktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
   
7.     For I = 10 To 15
   
8.         Range("A7") = Cells(I, 2)
   
9.         Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
10.         ActiveSheet.Pictures.Paste.Select
    
11.         With Selection
    
12.             .Copy
    
13.             With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
    
14.                 .Paste
    
15.                 .Export Desktop & "\m" & Range("A1") & ".jpg"
    
16.                 .Parent.Delete
    
17.             End With
    
18.             .Delete
    
19.         End With
    
20.         Application.Wait (Now + TimeValue("0:00:01"))
    
21.     Next
    
22. End Sub
    

复制代码

白云无尽9987

zjdh 发表于 2015-6-5 12:40

非常感谢！我也这样想过，但是不坚定、不清晰的思维环境下没有成功！