GBKEE

回復 1# skyutm
試試看

下載 (53.55 KB)

2012-10-5 08:22

GBKEE

回復 6# skyutm
是這樣嗎?

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, 照片位置 As Range
   
4.     Set Sh = ActiveSheet
   
5.     Set 照片位置 = Sh.[d5]
   
6.     With Sh
   
7.         .Pictures.Delete                                    '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
   
8.         With .[IV1]
   
9.             .FormulaR1C1 = "李大" & Chr(10) & "明印"
   
10.             .Font.Size = 14
    
11.             .Font.ColorIndex = 3
    
12.             .Font.Name = "華康古印體(P)"                    '修改你PC上的字體
    
13.             .HorizontalAlignment = xlCenter
    
14.             .VerticalAlignment = xlCenter
    
15.             .WrapText = True
    
16.             .MergeCells = False
    
17.             .Copy
    
18.         End With
    
19.         With .Pictures.Paste
    
20.             .Placement = xlMoveAndSize
    
21.             .PrintObject = True
    
22.             .Top = 照片位置.Top                             '圖片:頂端位置
    
23.             .Left = 照片位置.Left                           '圖片:左邊位置
    
24.             .ShapeRange.Fill.Visible = msoTrue              '圖片背景 顯示
    
25.            ' .ShapeRange.Fill.ForeColor.SchemeColor = 41    '背景顏色
    
26.              .ShapeRange.Line.Visible = msoTrue             '圖片邊框 顯示
    
27.             .ShapeRange.Line.Weight = 0.75                  '邊框.厚度
    
28.           '  .ShapeRange.Line.Visible = msoTrue
    
29.             .ShapeRange.Line.ForeColor.SchemeColor = 10     '圖片邊框.顏色
    
30.          '   .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
31.         End With
    
32.         .[IV1] = ""
    
33.     End With
    
34. End Sub

複製代碼

GBKEE

回復 13# skyutm

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, M(1 To 2) As String, E As Range
   
4.     Set Sh = ActiveSheet
   
5.     'Set 照片位置 = Sh.[d5]
   
6.     With ActiveSheet
   
7.         .Pictures.Delete                                    '刪除工作表全部圖片(如還有其餘樣式的 Shape 會一併刪除)
   
8.         For Each E In .[a1:a10]                            '*****[a1:a10] 已有姓名*****
   
9.             M(1) = E
   
10.             M(2) = Mid(E, 1, 2) & Chr(10) & Mid(E, 3, IIf(Len(E) < 3, 1, Len(E) - 2)) & "印"
    
11.             With E
    
12.             .FormulaR1C1 = M(2)
    
13.             .Font.Size = 14
    
14.             .Font.ColorIndex = 3
    
15.             .Font.Name = "華康古印體(P)"                    '修改你PC上的字體
    
16.             .HorizontalAlignment = xlCenter
    
17.             .VerticalAlignment = xlCenter
    
18.             .WrapText = True
    
19.             .EntireRow.AutoFit                              '自動調整列高
    
20.             .Copy
    
21.         End With
    
22.         With .Pictures.Paste
    
23.             .Placement = xlMoveAndSize
    
24.             .PrintObject = True
    
25.             
    
26.             '*********** 圖片貼在[B1:B10]     *******
    
27.             .Top = E.Offset(, 1).Top                        '圖片:頂端位置
    
28.             .Left = E.Offset(, 1).Left                      '圖片:左邊位置
    
29.             E.Offset(, 1).RowHeight = E.RowHeight           '圖片貼在[B1:B10] 調整 列高
    
30.             E.Offset(, 1).ColumnWidth = E.ColumnWidth       '圖片貼在[B1:B10] 調整 欄寬
    
31.              '*********** 圖片貼在[B1:B10]     *******
    
32.             
    
33.             .ShapeRange.Fill.Visible = msoTrue              '圖片背景 顯示
    
34.            ' .ShapeRange.Fill.ForeColor.SchemeColor = 41    '背景顏色
    
35.              .ShapeRange.Line.Visible = msoTrue             '圖片邊框 顯示
    
36.             .ShapeRange.Line.Weight = 0.75                  '邊框.厚度
    
37.           '  .ShapeRange.Line.Visible = msoTrue
    
38.             .ShapeRange.Line.ForeColor.SchemeColor = 10     '圖片邊框.顏色
    
39.          '   .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
40.         End With
    
41.         E.Clear
    
42.         E = M(1)
    
43.         Next
    
44.     End With
    
45. End Sub

複製代碼

GBKEE

回復 15# skyutm

1. With Sheets("成績單")
   
2.     For i = 0 To j
   
3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
   
4.     Next i
   
5.              .Pictures.ShapeRange.IncrementLeft 45
   
6.              .Pictures.ShapeRange.IncrementTop 5
   
7.            '**** 也會跟著移動*****       .Pictures -> Sheets("成績單")的所有圖片
   
8.     End With

複製代碼

試試看

1. With Sheets("成績單")
   
2.     For i = 0 To j
   
3.              .Paste Destination:=.Range("d" & 22 + 26 * i)
   
4.               a = .Pictures.Count
   
5.              .Pictures(a).ShapeRange.IncrementLeft 45
   
6.              .Pictures(a).ShapeRange.IncrementTop 5
   
7.     Next i
   
8.     End With

複製代碼

GBKEE

回復 18# skyutm
副檔名 .xlsx 為2003以上的版本 存為無巨集的活頁簿 應該沒有你說的問題

如是2003版可試試看  如執行有錯誤 請看  http://gb.twbts.com/index.php?topic=751.8

1. Sub macor24()
   
2.     Dim a, b, u, v, r, n As String, xlVbc As Object
   
3.     a = Sheets("基本設定").Range("a6").Value
   
4.     b = Sheets("基本設定").Range("a8").Value
   
5.     u = Sheets("基本設定").Range("j1").Value
   
6.     v = Sheets("基本設定").Range("j2").Value
   
7.     r = "C:\Documents and Settings\Administrator\桌面\"
   
8.     n = a & "學年度" & b & "學期" & u & "年" & v & "班成績檔"
   
9.     Sheets("成績儲存").Copy
   
10.     Sheets(1).Copy
    
11.     Application.DisplayAlerts = False
    
12.     With ActiveWorkbook
    
13.         For Each xlVbc In .VBProject.VBComponents
    
14.             xlVbc.CodeModule.DeleteLines 1, xlVbc.CodeModule.CountOfLines
    
15.         Next
    
16.         .SaveAs Filename:=r & n & ".xls"
    
17.     End With
    
18.     ThisWorkbook.Close savechanges:=True
    
19. End Sub

複製代碼

GBKEE

回復 20# skyutm
語法執行之後，還是會有語法錯誤
是哪一行程式碼錯誤,錯誤值是多少,或是附檔看看.

GBKEE

回復 23# skyutm
20# 的程式碼有修改空間

1. Option Explicit
   
2. Sub Ex() '練習試試看   活頁簿,工作表: 須皆沒上鎖的狀態
   
3.     Workbooks(1).Sheets(1).Copy            ' Sheets(1) 請先製作VBA巨集
   
4.     'Workbooks("TEST").Sheets("TEST").Copy   ' Sheets(1) 請先製作VBA巨集
   
5.     With ActiveWorkbook
   
6.         Application.DisplayAlerts = False
   
7.         .SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8
   
8.          '**  副檔名:xlsx  為無VBA巨集 的活頁簿
   
9.         Application.DisplayAlerts = False
   
10.     End With
    
11. End Sub

複製代碼

GBKEE

回復 25# skyutm
請問你執行程式後有將此檔案關閉,然後在打開看看,此檔案依然是有巨集存在嗎?
再試試看

1. Sub Ex() '練習試試看   活頁簿,工作表: 須皆沒上鎖的狀態
   
2.     Workbooks(1).Sheets(1).Copy            ' Sheets(1) 請先製作VBA巨集
   
3.     'Workbooks("TEST").Sheets("TEST").Copy   ' Sheets(1) 請先製作VBA巨集
   
4.     With ActiveWorkbook
   
5.         Application.DisplayAlerts = False
   
6.         .SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8
   
7.          '**  副檔名:xlsx  為無VBA巨集 的活頁簿
   
8.         Application.DisplayAlerts = False
   
9.         .Close
   
10.     End With
    
11.     Workbooks.Open ("d:\無巨集.xlsx")
    
12. End Sub

複製代碼

GBKEE

回復 28# skyutm
執行2 4# 的程式碼後 須將檔案關閉,然後再打開才會無巨集

1. Workbooks(1).Sheets(1).Copy        '->複製Sheets(1) 的工作表會在新增的活頁簿      
   
2. With ActiveWorkbook                     '>新增的活頁簿
   
3.         Application.DisplayAlerts = False
   
4.         .SaveAs "d:\無巨集.xlsx", FileFormat:=51 ' xlExcel8
   
5.       '**  副檔名:xlsx  為無VBA巨集 的活頁簿
   
6.       '***'存檔後 還是有巨集
   
7.         Application.DisplayAlerts = False
   
8.      .Close            '26#新加的程式碼  *** 關閉檔案
   
9.     End With
   
10.     Workbooks.Open ("d:\無巨集.xlsx")   '26#新加的程式碼  *** 開啟檔案

複製代碼

GBKEE

回復 30# skyutm
加一行On Error Resume Next，這樣就可以解決了。（不知這樣有無風險嗎？）
是有的 如有錯誤的語法或變數書寫錯誤, VBA是不處裡的.
請附檔看看